524 lines
15 KiB
Plaintext
524 lines
15 KiB
Plaintext
; Mode: Scheme
|
|
;
|
|
;
|
|
; **********************************************************************
|
|
; Copyright (c) 1992 Xerox Corporation.
|
|
; All Rights Reserved.
|
|
;
|
|
; Use, reproduction, and preparation of derivative works are permitted.
|
|
; Any copy of this software or of any derivative work must include the
|
|
; above copyright notice of Xerox Corporation, this paragraph and the
|
|
; one after it. Any distribution of this software or derivative works
|
|
; must comply with all applicable United States export control laws.
|
|
;
|
|
; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
|
|
; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
|
|
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
|
; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
|
|
; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
|
|
; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
|
|
; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
|
|
; OF THE POSSIBILITY OF SUCH DAMAGES.
|
|
; **********************************************************************
|
|
;
|
|
; EDIT HISTORY:
|
|
;
|
|
; 10/**/92 Gregor Originally Written
|
|
; 1.0 11/10/92 Gregor Changed names of generic invocation generics.
|
|
; Changed compute-getters-and-setters protocol.
|
|
; Made comments match the code.
|
|
; Changed maximum line width to 72.
|
|
; 1.1 11/24/92 Gregor Heavily edited to produce the reflective
|
|
; RPP processor program that is actually running.
|
|
; This is intended to be a tool for discussing
|
|
; what the language and protocol should be.
|
|
; In the process of doing this, several small
|
|
; bugs were discovered, see the tiny-clos.scm
|
|
; file.
|
|
; 1.2 12/02/92 Gregor See tiny-clos.scm.
|
|
; 1.3 12/08/92 Gregor See tiny-clos.scm.
|
|
;
|
|
;
|
|
(define tiny-clos-version "1.3.RPP")
|
|
|
|
;
|
|
; A very simple CLOS-like language, embedded in Scheme, with a simple
|
|
; MOP. The features of the default base language are:
|
|
;
|
|
; * Classes, with instance slots, but no slot options.
|
|
; * Multiple-inheritance.
|
|
; * Generic functions with multi-methods and class specializers only.
|
|
; * Primary methods and call-next-method; no other method combination.
|
|
; * Uses Scheme's lexical scoping facilities as the class and generic
|
|
; function naming mechanism. Another way of saying this is that
|
|
; class, generic function and methods are first-class (meta)objects.
|
|
;
|
|
; While the MOP is simple, it is essentially equal in power to both MOPs
|
|
; in AMOP. This implementation is not at all optimized, but the MOP is
|
|
; designed so that it can be optimized. In fact, this MOP allows better
|
|
; optimization of slot access extenstions than those in AMOP.
|
|
;
|
|
;
|
|
;
|
|
; In addition to calling a generic, the entry points to the default base
|
|
; language are:
|
|
;
|
|
; (MAKE-CLASS list-of-superclasses list-of-slot-names)
|
|
; (MAKE-GENERIC)
|
|
; (MAKE-METHOD list-of-specializers procedure)
|
|
; (ADD-METHOD generic method)
|
|
;
|
|
; (MAKE class . initargs)
|
|
; (INITIALIZE instance initargs) ;Add methods to this,
|
|
; ;don't call it directly.
|
|
;
|
|
; (SLOT-REF object slot-name)
|
|
; (SLOT-SET! object slot-name new-value)
|
|
;
|
|
;
|
|
; So, for example, one might do:
|
|
;
|
|
; (define <position> (make-class (list <object>) (list 'x 'y)))
|
|
; (add-method initialize
|
|
; (make-method (list <position>)
|
|
; (lambda (call-next-method pos initargs)
|
|
; (for-each (lambda (initarg-name slot-name)
|
|
; (slot-set! pos
|
|
; slot-name
|
|
; (getl initargs initarg-name 0)))
|
|
; '(x y)
|
|
; '(x y)))))
|
|
;
|
|
; (set! p1 (make <position> 'x 1 'y 3))
|
|
;
|
|
;
|
|
;
|
|
; NOTE! Do not use EQUAL? to compare objects! Use EQ? or some hand
|
|
; written procedure. Objects have a pointer to their class,
|
|
; and classes are circular structures, and ...
|
|
;
|
|
;
|
|
;
|
|
; The introspective part of the MOP looks like the following. Note that
|
|
; these are ordinary procedures, not generics.
|
|
;
|
|
; CLASS-DIRECT-SUPERS
|
|
; CLASS-DIRECT-SLOTS
|
|
; CLASS-CPL
|
|
; CLASS-SLOTS
|
|
;
|
|
; GENERIC-METHODS
|
|
;
|
|
; METHOD-SPECIALIZERS
|
|
; METHOD-PROCEDURE
|
|
;
|
|
;
|
|
; The intercessory protocol looks like (generics in uppercase):
|
|
;
|
|
; make
|
|
; ALLOCATE-INSTANCE
|
|
; INITIALIZE (really a base-level generic)
|
|
;
|
|
; class initialization
|
|
; COMPUTE-CPL
|
|
; COMPUTE-SLOTS
|
|
; COMPUTE-GETTER-AND-SETTER
|
|
;
|
|
; add-method (Notice this is not a generic!)
|
|
; COMPUTE-APPLY-GENERIC
|
|
; COMPUTE-METHODS
|
|
; COMPUTE-METHOD-MORE-SPECIFIC?
|
|
; COMPUTE-APPLY-METHODS
|
|
;
|
|
|
|
;
|
|
; As for the low-level memory system, assume the existence of:
|
|
;
|
|
; %allocate-instance (nfields)
|
|
; %instance-ref (instance field-number)
|
|
; %instance-set! (instance field-number new)
|
|
;
|
|
; %allocate-entity (nfields)
|
|
; %entity-ref (instance field-number)
|
|
; %entity-set! (instance field-number new)
|
|
;
|
|
; class-of (any-object)
|
|
;
|
|
|
|
|
|
(define <top> (make <class>
|
|
'direct-supers (list)
|
|
'direct-slots (list)))
|
|
|
|
(define <object> (make <class>
|
|
'direct-supers (list <top>)
|
|
'direct-slots (list)))
|
|
|
|
(define <class>
|
|
(make <class>
|
|
'direct-supers (list <object>)
|
|
'direct-slots
|
|
(list 'direct-supers ;(class ...)
|
|
'direct-slots ;((name . options) ...)
|
|
'cpl ;(class ...)
|
|
'slots ;((name . options) ...)
|
|
'nfields ;an integer
|
|
'field-initializers ;(proc ...)
|
|
'getters-n-setters))) ;((slot-name getter setter) ...)
|
|
|
|
(define <primitive-class>
|
|
(make <class>
|
|
'direct-supers (list <class>)
|
|
'direct-slots (list)))
|
|
|
|
(define make-primitive-class
|
|
(lambda class
|
|
(make (if (null? class) <primitive-class> (car class))
|
|
'direct-supers (list <top>)
|
|
'direct-slots (list))))
|
|
|
|
(define <boolean> (make-primitive-class))
|
|
(define <symbol> (make-primitive-class))
|
|
(define <char> (make-primitive-class))
|
|
(define <vector> (make-primitive-class))
|
|
(define <pair> (make-primitive-class))
|
|
(define <number> (make-primitive-class))
|
|
(define <string> (make-primitive-class))
|
|
(define <procedure> (make-primitive-class <procedure-class>))
|
|
|
|
|
|
(define <procedure-class> (make <class>
|
|
'direct-supers (list <class>)
|
|
'direct-slots (list)))
|
|
|
|
(define <entity-class> (make <class>
|
|
'direct-supers (list <procedure-class>)
|
|
'direct-slots (list)))
|
|
|
|
(define <generic> (make <entity-class>
|
|
'direct-supers (list <object>)
|
|
'direct-slots (list 'methods)))
|
|
|
|
(define <method> (make <class>
|
|
'direct-supers (list <object>)
|
|
'direct-slots (list 'specializers
|
|
'procedure)))
|
|
|
|
;
|
|
; To make the introspective MOP cleaner, we hide the slot names, in the
|
|
; usual CLOS style. The following are the acccessors which should be
|
|
; used to access information stored in metaobjects.
|
|
;
|
|
;
|
|
(define class-direct-slots
|
|
(lambda (class) (slot-ref class 'direct-slots)))
|
|
(define class-direct-supers
|
|
(lambda (class) (slot-ref class 'direct-supers)))
|
|
(define class-slots
|
|
(lambda (class) (slot-ref class 'slots)))
|
|
(define class-cpl
|
|
(lambda (class) (slot-ref class 'cpl)))
|
|
|
|
(define generic-methods
|
|
(lambda (generic) (slot-ref generic 'methods)))
|
|
|
|
(define method-specializers
|
|
(lambda (method) (slot-ref method 'specializers)))
|
|
(define method-procedure
|
|
(lambda (method) (slot-ref method 'procedure)))
|
|
|
|
|
|
;
|
|
; The initialization protocol
|
|
;
|
|
(define initialize (make-generic))
|
|
|
|
|
|
;
|
|
; The instance structure protocol.
|
|
;
|
|
(define allocate-instance (make-generic))
|
|
(define compute-getter-and-setter (make-generic))
|
|
|
|
|
|
;
|
|
; The class initialization protocol.
|
|
;
|
|
(define compute-cpl (make-generic))
|
|
(define compute-slots (make-generic))
|
|
|
|
;
|
|
; The generic invocation protocol.
|
|
;
|
|
(define compute-apply-generic (make-generic))
|
|
(define compute-methods (make-generic))
|
|
(define compute-method-more-specific? (make-generic))
|
|
(define compute-apply-methods (make-generic))
|
|
|
|
|
|
|
|
(add-method initialize
|
|
(make-method (list <object>)
|
|
(lambda (call-next-method object initargs) object)))
|
|
|
|
(add-method initialize
|
|
(make-method (list <class>)
|
|
(lambda (call-next-method class initargs)
|
|
(call-next-method)
|
|
(slot-set! class
|
|
'direct-supers
|
|
(getl initargs 'direct-supers '()))
|
|
(slot-set! class
|
|
'direct-slots
|
|
(map (lambda (s)
|
|
(if (pair? s) s (list s)))
|
|
(getl initargs 'direct-slots '())))
|
|
(slot-set! class 'cpl (compute-cpl class))
|
|
(slot-set! class 'slots (compute-slots class))
|
|
(let* ((nfields 0)
|
|
(field-initializers '())
|
|
(allocator
|
|
(lambda (init)
|
|
(let ((f nfields))
|
|
(set! nfields (+ nfields 1))
|
|
(set! field-initializers
|
|
(cons init field-initializers))
|
|
(list (lambda (o) (get-field o f))
|
|
(lambda (o n) (set-field! o f n))))))
|
|
(getters-n-setters
|
|
(map (lambda (slot)
|
|
(cons (car slot)
|
|
(compute-getter-and-setter class
|
|
slot
|
|
allocator)))
|
|
(slot-ref class 'slots))))
|
|
(slot-set! class 'nfields nfields)
|
|
(slot-set! class 'field-initializers field-initializers)
|
|
(slot-set! class 'getters-n-setters getters-n-setters)))))
|
|
|
|
(add-method initialize
|
|
(make-method (list <generic>)
|
|
(lambda (call-next-method generic initargs)
|
|
(call-next-method)
|
|
(slot-set! generic 'methods '())
|
|
(%set-entity-proc! generic
|
|
(lambda args (error "Has no methods."))))))
|
|
|
|
(add-method initialize
|
|
(make-method (list <method>)
|
|
(lambda (call-next-method method initargs)
|
|
(call-next-method)
|
|
(slot-set! method 'specializers (getl initargs 'specializers))
|
|
(slot-set! method 'procedure (getl initargs 'procedure)))))
|
|
|
|
|
|
|
|
(add-method allocate-instance
|
|
(make-method (list <class>)
|
|
(lambda (call-next-method class)
|
|
(let* ((field-initializers (slot-ref class 'field-initializers))
|
|
(new (%allocate-instance
|
|
class
|
|
(length field-initializers))))
|
|
(let loop ((n 0)
|
|
(inits field-initializers))
|
|
(if (pair? inits)
|
|
(begin
|
|
(%instance-set! new n ((car inits)))
|
|
(loop (+ n 1)
|
|
(cdr inits)))
|
|
new))))))
|
|
|
|
(add-method allocate-instance
|
|
(make-method (list <entity-class>)
|
|
(lambda (call-next-method class)
|
|
(let* ((field-initializers (slot-ref class 'field-initializers))
|
|
(new (%allocate-entity
|
|
class
|
|
(length field-initializers))))
|
|
(let loop ((n 0)
|
|
(inits field-initializers))
|
|
(if (pair? inits)
|
|
(begin
|
|
(%entity-set! new n ((car inits)))
|
|
(loop (+ n 1)
|
|
(cdr inits)))
|
|
new))))))
|
|
|
|
|
|
|
|
(add-method compute-cpl
|
|
(make-method (list <class>)
|
|
(lambda (call-next-method class)
|
|
(compute-std-cpl class class-direct-supers))))
|
|
|
|
|
|
(add-method compute-slots
|
|
(make-method (list <class>)
|
|
(lambda (call-next-method class)
|
|
(let collect ((to-process (apply append
|
|
(map class-direct-slots
|
|
(class-cpl class))))
|
|
(result '()))
|
|
(if (null? to-process)
|
|
(reverse result)
|
|
(let* ((current (car to-process))
|
|
(name (car current))
|
|
(others '())
|
|
(remaining-to-process
|
|
(collect-if (lambda (o)
|
|
(if (eq? (car o) name)
|
|
(begin
|
|
(set! others (cons o others))
|
|
#f)
|
|
#t))
|
|
(cdr to-process))))
|
|
(collect remaining-to-process
|
|
(cons (append current
|
|
(apply append (map cdr others)))
|
|
result))))))))
|
|
|
|
|
|
(add-method compute-getter-and-setter
|
|
(make-method (list <class>)
|
|
(lambda (call-next-method class slot allocator)
|
|
(allocator (lambda () '())))))
|
|
|
|
(define make
|
|
(lambda (class . initargs)
|
|
(let ((instance (allocate-instance class)))
|
|
(initialize instance initargs)
|
|
instance)))
|
|
|
|
(define slot-ref
|
|
(lambda (object slot-name)
|
|
(let* ((info (lookup-slot-info (class-of object) slot-name))
|
|
(getter (list-ref info 0)))
|
|
(getter object))))
|
|
|
|
(define slot-set!
|
|
(lambda (object slot-name new-value)
|
|
(let* ((info (lookup-slot-info (class-of object) slot-name))
|
|
(setter (list-ref info 1)))
|
|
(setter object new-value))))
|
|
|
|
(define lookup-slot-info
|
|
(lambda (class slot-name)
|
|
(let* ((getters-n-setters (slot-ref class 'getters-n-setters))
|
|
(entry (assq slot-name getters-n-setters)))
|
|
(if (null? entry)
|
|
(error "No slot" slot-name "in instances of" class)
|
|
(cdr entry)))))
|
|
|
|
|
|
(define add-method
|
|
(lambda (generic method)
|
|
(slot-set! generic
|
|
'methods
|
|
(cons method
|
|
(filter-in
|
|
(lambda (m)
|
|
(not (every eq?
|
|
(method-specializers m)
|
|
(method-specializers method))))
|
|
(slot-ref generic 'methods))))
|
|
(%set-entity-proc! generic (compute-apply-generic generic))))
|
|
|
|
|
|
(add-method compute-apply-generic
|
|
(make-method (list <generic>)
|
|
(lambda (call-next-method generic)
|
|
(lambda args
|
|
((compute-apply-methods generic)
|
|
((compute-methods generic) args)
|
|
args)))))
|
|
|
|
(add-method compute-methods
|
|
(make-method (list <generic>)
|
|
(lambda (call-next-method generic)
|
|
(lambda (args)
|
|
(let ((applicable
|
|
(filter-in (lambda (method)
|
|
;
|
|
; Note that every only goes as far as the
|
|
; shortest list!
|
|
;
|
|
(every applicable?
|
|
(method-specializers method)
|
|
args))
|
|
(generic-methods generic))))
|
|
(gsort (lambda (m1 m2)
|
|
((compute-method-more-specific? generic)
|
|
m1
|
|
m2
|
|
args))
|
|
applicable))))))
|
|
|
|
(add-method compute-method-more-specific?
|
|
(make-method (list <generic>)
|
|
(lambda (call-next-method generic)
|
|
(lambda (m1 m2 args)
|
|
(let loop ((specls1 (method-specializers m1))
|
|
(specls2 (method-specializers m2))
|
|
(args args))
|
|
(cond ((null? specls1) (return #t)) ;*Maybe these two
|
|
((null? specls2) (return #f)) ;*should barf?
|
|
((null? args)
|
|
(error "Fewer arguments than specializers."))
|
|
(else
|
|
(let ((c1 (car specls1))
|
|
(c2 (car specls2))
|
|
(arg (car args)))
|
|
(if (eq? c1 c2)
|
|
(loop (cdr specls1)
|
|
(cdr specls2)
|
|
(cdr args))
|
|
(more-specific? c1 c2 arg))))))))))
|
|
|
|
(define applicable?
|
|
(lambda (c arg)
|
|
(memq c (class-cpl (class-of arg)))))
|
|
|
|
(define more-specific?
|
|
(lambda (c1 c2 arg)
|
|
(memq c2 (memq c1 (class-cpl (class-of arg))))))
|
|
|
|
(add-method compute-apply-methods
|
|
(make-method (list <generic>)
|
|
(lambda (call-next-method generic)
|
|
(lambda (methods args)
|
|
(letrec ((one-step
|
|
(lambda (tail)
|
|
(lambda ()
|
|
(if (null? tail)
|
|
(error "No applicable methods/next methods.")
|
|
(apply (method-procedure (car tail))
|
|
(cons (one-step (cdr tail)) args)))))))
|
|
((one-step methods)))))))
|
|
|
|
|
|
|
|
|
|
;
|
|
; So that the normal base-level user can live life without knowing there
|
|
; is a MOP, we supply the following convenient syntax.
|
|
;
|
|
;
|
|
(define make-class
|
|
(lambda (direct-supers direct-slots)
|
|
(make <class>
|
|
'direct-supers direct-supers
|
|
'direct-slots direct-slots)))
|
|
|
|
(define make-generic
|
|
(lambda ()
|
|
(make <generic>)))
|
|
|
|
(define make-method
|
|
(lambda (specializers procedure)
|
|
(make <method>
|
|
'specializers specializers
|
|
'procedure procedure)))
|
|
|
|
|