tinyclos/tiny-rpp.text

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)))