1
;;; wlos.scm: Wacky Lightweight Object System
3
;;; Copyright (c) 2007-2011 uim Project http://code.google.com/p/uim/
5
;;; All rights reserved.
7
;;; Redistribution and use in source and binary forms, with or without
8
;;; modification, are permitted provided that the following conditions
11
;;; 1. Redistributions of source code must retain the above copyright
12
;;; notice, this list of conditions and the following disclaimer.
13
;;; 2. Redistributions in binary form must reproduce the above copyright
14
;;; notice, this list of conditions and the following disclaimer in the
15
;;; documentation and/or other materials provided with the distribution.
16
;;; 3. Neither the name of authors nor the names of its contributors
17
;;; may be used to endorse or promote products derived from this software
18
;;; without specific prior written permission.
20
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
21
;;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
22
;;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
23
;;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
24
;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25
;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26
;;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
;; Wacky Lightweight Object System (WLOS, pronounced as wa-loss like
33
;; CLOS as kloss, or in Japanese, ワロス) is designed to provide less
34
;; resource consumptive and efficient object oriented programming
35
;; environment. -- YamaKen 2007-08-19
37
;; Characteristics of WLOS:
41
;; Method selection is only based on the receiver object.
45
;; All instances of a class share identical type information
46
;; including method table. But 'object-derive' allows making
47
;; singleton object and per-object method redefinition. All methods
48
;; listed in define-class are polymorphic.
50
;; - Single inheritance
52
;; Only one superclass can be inherited. Though WLOS does not have
53
;; multiple inheritance -like feature such as interfaces or mix-ins,
54
;; "call by name" methods can be used to achieve such flexibility.
58
;; Though method redefinition on the fly can be performed, no new
59
;; method can dynamically be added to a class once define-class has
62
;; - Inheritance by copy
64
;; Even if a superclass method is redefined, the change does not
65
;; affect decendant classes. The method table is only copied at
70
;; Normal method call on WLOS is performed by retrieving a method
71
;; by integer index to the method table, as like as vptr-based
72
;; method call on C++. So an inheritance is required to make a method
77
;; In addition to the index-based method call described above, call
78
;; by name (method name symbol, accurately) is also supported for
79
;; flexible object oriented programming. 'call-method' and
80
;; 'call-supermethod' are provided for explicit method call, and
81
;; 'make-call-by-name-method-dispatcher' is for defining a method
82
;; dispatcher with implicit name-based call. Inheritance-less
83
;; polymorphism (i.e. duck typing) can be performed by them. Define
84
;; field-accessors as method if you want to access them without type
89
;; An object instance cannot be distinguished from its actual data
90
;; type such as vector or list. And both method dispatcher and
91
;; method itself does not check whether the receiver object is
92
;; suitable for the method. Ensuring method & receiver combination
93
;; valid is user's responsibility.
95
;; - No information hiding
97
;; All field accessors and methods are public. If you want to hide
98
;; some of them, make them inaccesible or rename to a private name.
100
;; ;; inhibit object copy and modification of 'var' field
101
;; (define foo-copy #f)
102
;; (define foo-set-var! #f)
104
;; ;; make equal? method dispatcher for class bar private
105
;; (define %bar-equal? bar-equal?)
106
;; (define bar-equal? #f)
108
;; - Alternative list-based object representation
110
;; In addition to the normal vector-based object, list-based object
111
;; is also available to save memory consumption. The list-based
112
;; object allows sharing some common tail fields (physically tail
113
;; fields, but logically ancestral-class fields) between multiple
114
;; objects. This feature is the main reason why WLOS is named as
120
;; - (define-class name super fld-specs+ method-names+)
121
;; - (class-superclass klass)
122
;; - (class-is-a? klass another)
123
;; - (class-find-method klass method-name)
124
;; - (class-set-method! klass method-name proc)
127
;; - (make-method-dispatcher-name class-name method-name)
128
;; - (make-method-dispatcher klass method-name)
129
;; - (make-call-by-name-method-dispatcher method-name)
130
;; - (call-method method-name . self.args)
131
;; - (call-supermethod method-name . self.args)
132
;; - (method-fold obj . method-forms)
135
;; - (object-class self)
136
;; - (object-superclass self)
137
;; - (object-is-a? self klass)
138
;; - (object-equal? self)
139
;; - (object-copy self)
140
;; - (object-partial-clone self last-shared-field-name)
141
;; - (object-derive self)
143
(require-extension (srfi 1 23))
144
;; vector-copy, vector-index, vector-append
148
(require-extension (srfi 43))))
150
(require "util.scm") ;; safe-car, symbol-append
151
(require "light-record.scm")
154
(define %HYPHEN-SYM (string->symbol "-"))
157
(if (symbol-bound? 'vector-copy)
160
(list->vector (vector->list v)))))
163
(if (symbol-bound? 'vector-index)
166
(list-index pred (vector->list v)))))
168
(define vector-append
169
(if (symbol-bound? 'vector-append)
172
(list->vector (append-map vector->list vectors)))))
175
;; dual-form record for WLOS objects
177
(define %vector-based-wlos-record? vector?)
178
(define %list-based-wlos-record? list?)
180
(define %make-vector-based-wlos-record-constructor-name
182
(symbol-append 'make-vector-based- rec-name)))
184
(define %make-list-based-wlos-record-constructor-name
186
(symbol-append 'make-list-based- rec-name)))
188
(define %list->vector-based-wlos-record list->vector)
190
;; index 0 is located on last cell
191
(define %list->list-based-wlos-record reverse)
193
(define %wlos-record->list
195
((if (%vector-based-wlos-record? rec)
200
(define %wlos-record-copy
202
((if (%vector-based-wlos-record? rec)
207
(define %wlos-record-ref
209
(if (%vector-based-wlos-record? rec)
210
(vector-ref rec index)
211
;; FIXME: optimize to 1-pass implementation
216
(define %wlos-record-set!
217
(lambda (rec index val)
218
(if (%vector-based-wlos-record? rec)
219
(vector-set! rec index val)
220
;; FIXME: optimize to 1-pass implementation
226
(define-macro %define-wlos-record
227
(lambda (rec-name fld-specs)
229
;; make-<rec-name> is bind to make-vector-based-<rec-name> by default
230
(define-record-generic
232
%list->vector-based-wlos-record
233
%wlos-record-copy %wlos-record-ref %wlos-record-set!)
234
;; make-vector-based-<rec-name>
235
(define ,(%make-vector-based-wlos-record-constructor-name rec-name)
236
,(make-record-constructor-name rec-name))
237
;; make-list-based-<rec-name>
238
(define ,(%make-list-based-wlos-record-constructor-name rec-name)
239
(%make-record-constructor ',rec-name ,fld-specs
240
%list->list-based-wlos-record)))))
247
(define-vector-record class
248
'((ancestors ()) ;; (super grand-super ... object)
249
(field-specs (class)) ;; record-spec for instance
250
(method-names #()))) ;; hold as vector to make call-by-name efficient
252
(define class-superclass
254
(or (safe-car (class-ancestors klass))
255
(error "no superclass"))))
258
(lambda (klass another)
259
(or (eq? klass another)
260
(not (not (memq another (class-ancestors klass)))))))
262
(define %class-method-index
263
(lambda (klass method-name)
264
;; FIXME: replace with faster implementation
265
(vector-index (lambda (x)
267
(class-method-names klass))))
269
(define %class-method-field-index
270
(lambda (klass method-name)
271
(+ (vector-length class)
272
(%class-method-index klass method-name))))
274
(define class-find-method
275
(lambda (klass method-name)
276
(vector-ref klass (%class-method-field-index klass method-name))))
278
(define %class-set-method!
279
(lambda (klass method-name proc)
280
(vector-set! klass (%class-method-field-index klass method-name) proc)))
282
(define-macro class-set-method!
283
(lambda (klass method-name proc)
284
`(%class-set-method! ,klass ',method-name ,proc)))
287
(lambda (super fld-specs+ method-names+)
288
(let ((ancestors (if (eq? super class) ;; bootstrap
290
(cons super (class-ancestors super))))
291
(fld-specs (append (class-field-specs super) fld-specs+))
292
(method-names (vector-append (class-method-names super)
293
(list->vector method-names+)))
294
(klass (vector-append super (make-vector (length method-names+)
295
%undefined-method))))
296
(set-car! fld-specs `(class ,klass))
297
(class-set-ancestors! klass ancestors)
298
(class-set-field-specs! klass fld-specs)
299
(class-set-method-names! klass method-names)
302
(define-macro %define-methods
303
(lambda (klass-name method-names)
305
(map (lambda (method-name)
306
`(define ,(make-method-dispatcher-name klass-name method-name)
307
(make-method-dispatcher ,klass-name ',method-name)))
310
(define-macro define-class
311
(lambda (name super fld-specs+ method-names+)
312
(let ((klass (apply %make-class
313
(eval `(list ,super ,fld-specs+ ,method-names+)
314
(interaction-environment)))))
316
;; define class object
317
(define ,name ',klass)
318
;; define instance structure as record
319
(%define-wlos-record ,name (class-field-specs ',klass))
320
;; redefine record object constructors as accepting class-less args
321
;; make-vector-based-<class>
322
(define ,(%make-vector-based-wlos-record-constructor-name name)
323
(let ((orig-constructor
324
,(%make-vector-based-wlos-record-constructor-name name)))
326
(apply orig-constructor (cons ',klass args)))))
327
;; make-list-based-<class>
328
(define ,(%make-list-based-wlos-record-constructor-name name)
329
(let ((orig-constructor
330
,(%make-list-based-wlos-record-constructor-name name)))
332
(apply orig-constructor (cons ',klass args)))))
333
;; make-<class> is bind to make-vector-based-<class> by default
334
(define ,(make-record-constructor-name name)
335
,(%make-vector-based-wlos-record-constructor-name name))
336
;; define method dispatchers
337
;; overwrites <class>-copy defined by define-*-record
338
(%define-methods ,name ,(vector->list (class-method-names klass)))))))
345
(define %dispatch-method
346
(lambda (index self.args)
347
(apply (vector-ref (object-class (car self.args)) index)
350
(define make-method-dispatcher-name
351
(lambda (class-name method-name)
352
(symbol-append class-name %HYPHEN-SYM method-name)))
354
;; To suppress redundant closure allocation, dispatchers for same
355
;; method index share identical procedure regardless of its class. And
356
;; hardcoded-index version of dispatchers are predefined for efficiency.
357
(define make-method-dispatcher
358
(let ((pool `((0 . ,(lambda self.args (%dispatch-method 0 self.args)))
359
(1 . ,(lambda self.args (%dispatch-method 1 self.args)))
360
(2 . ,(lambda self.args (%dispatch-method 2 self.args)))
361
(3 . ,(lambda self.args (%dispatch-method 3 self.args)))
362
(4 . ,(lambda self.args (%dispatch-method 4 self.args)))
363
(5 . ,(lambda self.args (%dispatch-method 5 self.args)))
364
(6 . ,(lambda self.args (%dispatch-method 6 self.args)))
365
(7 . ,(lambda self.args (%dispatch-method 7 self.args)))
366
(8 . ,(lambda self.args (%dispatch-method 8 self.args)))
367
(9 . ,(lambda self.args (%dispatch-method 9 self.args))))))
368
(lambda (klass method-name)
369
(let ((index (%class-method-field-index klass method-name)))
371
((assv index pool) => cdr)
373
(let ((dispatcher (lambda self.args
374
(%dispatch-method index self.args))))
375
(set! pool (alist-cons index dispatcher pool))
379
;; To explicitly indicate that this call is name-based, method name is
380
;; not automatically quoted by a macro.
382
(lambda (method-name . self.args)
383
(apply (class-find-method (object-class (car self.args)) method-name)
387
(define call-supermethod
388
(lambda (method-name . self.args)
389
(apply (class-find-method (object-superclass (car self.args)) method-name)
392
;; Used instead of interfaces or mix-ins
393
;; FIXME: define proper dispatcher-redefinition way for users
394
(define make-call-by-name-method-dispatcher
395
(lambda (method-name)
397
(apply (class-find-method (object-class (car self.args)) method-name)
400
;; Method call cascading on typical OO language such as
402
;; obj.method1(arg ...).method2(arg ...).method3
404
;; can be write on WLOS as folows.
406
;; (method-fold obj `(,method1 ,arg ...) `(,method2 ,arg ...) method3 ...)
408
(lambda (obj . method-forms)
409
(fold (lambda (method.args res)
411
((procedure? method.args)
413
((symbol? method.args)
414
(call-method method.args res))
416
(let ((method (car method.args))
417
(args (cdr method.args)))
420
(apply method (cons res args)))
422
(apply call-method (cons* method res args)))
424
(error "invalid method form")))))))
427
(define %undefined-method
428
(lambda (self . args)
429
(error "undefined method")))
437
(define class (make-class))
441
;; root of all classes
442
(define-class object class
447
copy ;; intentionally overwrites copy procedure defined by define-record
450
;; Since there is no way to distinguish whether a field value is expected
451
;; to be an WLOS object or normal Scheme object, auto-generated object
452
;; equivalence predicate below is next to useless. Define your own ones by
453
;; hand if needed. -- YamaKen 2008-08-12
454
(define make-object-equal?
457
(and (object-is-a? other (object-class self))
458
(let ((self-flds (cdr (%wlos-record->list self)))
459
(other-flds (cdr (%wlos-record->list other))))
460
;; Above object-is-a? predicate already ensured proper
461
;; fields existence. So true value on an unmatched length
462
;; lists is not a problem.
463
(every fld-equal? self-flds other-flds))))))
465
(class-set-method! object equal? (make-object-equal? equal?))
466
;;(class-set-method! object equal? eq?)
467
(class-set-method! object copy %wlos-record-copy)
469
;; optimization: intentionally overwrites the default definition
476
(define object-superclass
478
(class-superclass (object-class self))))
482
(class-is-a? (object-class self) klass)))
484
(class-set-method! object partial-clone
485
(lambda (self last-shared-field-name)
486
(if (not (%list-based-wlos-record? self))
487
(error "object-partial-clone: list-based object required but got " self))
488
(let* ((klass (object-class self))
489
(fld-names (map record-field-spec-name
490
(class-field-specs klass)))
491
(tail-len (+ (list-index fld-names last-shared-field-name)
493
(shared-tail (take-right self tail-len))
494
(copied-head (drop-right self tail-len)))
495
(append! copied-head shared-tail))))
497
;; Makes singleton object which allows per-object method redefinition.
499
;; (define singleton (object-derive obj))
500
;; (class-set-method! (object-class singleton) 'method-name method)
501
(define object-derive
503
(let ((derived (object-copy self))
504
(singleton-class (vector-copy (object-class self))))
505
(object-set-class! derived singleton-class)
added
removed
scm/wlos.scm
