conservatory
/
tinyclos
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit 

Contents of the directory ftp://ftp.parc.xerox.com/pub/mops/tiny/
from the snapshot https://archive.org/details/2014.01.ftp.parc.xerox.com
This commit is contained in:
Lassi Kortela 2023-07-01 09:38:05 +03:00
commit 320c3aacd5
5 changed files with 2133 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

257
support.scm Normal file
View File

@ -0,0 +1,257 @@
; 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.
; *************************************************************************
;
;
; Scheme is such a wonderful language, you can't program in it!
;
; This is a library of stuff I find useful. I'll bet there's dozens
; of these out there.
;
;
; In order to make this code more easily portable, we have to be
; explicit about its implementation dependencies. To do this, we
; have the following variable. Please adjust it before trying to
; run this code. See also the macro, scheme-implementation-case,
; which follows shortly.
;
; Note that some of these dependencies (i.e. gsort) are purely for
; convenience (i.e. saving me from writing sort from scratch).
; Others are more pressing, like define-macro.
;
;
(define what-scheme-implementation
'mit
;'chez
;'scm
;'scheme48 ; Scheme 48 requires that you do:
) ; ,open big-scheme
; before loading this file, in order
;for sort-list to be defined.
(case what-scheme-implementation
((scm)
(require 'sort)))
(define gsort
(case what-scheme-implementation
((mit) (lambda (predicate list) (sort list predicate)))
((chez) (lambda (predicate list) (sort predicate list)))
((scheme48) (lambda (predicate list) (sort-list predicate list)))
((scm) (lambda (predicate list) (sort list predicate)))))
(define simple-printer (lambda () barf))
(define ??? 'unspecified-result)
(define list*
(lambda args
(letrec ((chase
(lambda (args)
(cond ((null? args) '())
((null? (cdr args)) (car args))
(else (cons (car args) (chase (cdr args))))))))
(chase args))))
(define apply*
(lambda (proc . args)
(apply proc (apply list* args))))
(define position-of
(lambda (x lst)
(if (eq? x (car lst)) 0 (+ 1 (position-of x (cdr lst))))))
(define map-append
(lambda (proc . lists)
(apply append (apply map (cons proc lists)))))
(define last
(lambda (l)
(if (null? l)
#f
(if (null? (cdr l))
(car l)
(last (cdr l))))))
(define every
(lambda (test . lists)
(let scan ((tails lists))
(if (member #t (map null? tails)) ;(any null? lists)
#t
(and (apply test (map car tails))
(scan (map cdr tails)))))))
(define remove
(lambda (x list)
(cond ((null? list) '())
((eq? (car list) x) (cdr list))
(else (cons (car list) (remove x (cdr list)))))))
(define getl
(lambda (initargs name . not-found)
(letrec ((scan (lambda (tail)
(cond ((null? tail)
(if (pair? not-found)
(car not-found)
(error "GETL couldn't find" name)))
((eq? (car tail) name) (cadr tail))
(else (scan (cddr tail)))))))
(scan initargs))))
(define union
(lambda lists
(letrec ((clean (lambda (list result)
(cond ((null? list) result)
((memq (car list) result)
(clean (cdr list) result))
(else
(clean (cdr list) (cons (car list) result)))))))
(clean (apply append lists) '()))))
(define collect-if
(lambda (test? list)
(cond ((null? list) '())
((test? (car list)) (cons (car list) (collect-if test? (cdr list))))
(else (collect-if test? (cdr list))))))
;(define remove-unless
; (lambda (test list)
; (if (null? list)
; ()
; (let ((rest (remove-unless test (cdr list))))
; (if (test (car list))
; (cons (car list) rest)
; rest)))))
(define remove-duplicates
(lambda (list)
(let loop ((result-so-far '())
(remaining list))
(if (null? remaining)
result-so-far
(if (null? (memq (car remaining) result-so-far))
(loop (cons (car remaining) result-so-far)
(cdr remaining))
(loop result-so-far
(cdr remaining)))))))
;
; A simple topological sort.
;
; It's in this file so that both TinyClos and Objects can use it.
;
; This is a fairly modified version of code I originally got from Anurag
; Mendhekar <anurag@moose.cs.indiana.edu>.
;
;
(define compute-std-cpl
(lambda (c get-direct-supers)
(top-sort ((build-transitive-closure get-direct-supers) c)
((build-constraints get-direct-supers) c)
(std-tie-breaker get-direct-supers))))
(define top-sort
(lambda (elements constraints tie-breaker)
(let loop ((elements elements)
(constraints constraints)
(result '()))
(if (null? elements)
result
(let ((can-go-in-now
(collect-if
(lambda (x)
(every (lambda (constraint)
(or (not (eq? (cadr constraint) x))
(memq (car constraint) result)))
constraints))
elements)))
(if (null? can-go-in-now)
(error 'top-sort "Invalid constraints")
(let ((choice (if (null? (cdr can-go-in-now))
(car can-go-in-now)
(tie-breaker result
can-go-in-now))))
(loop
(collect-if (lambda (x) (not (eq? x choice)))
elements)
constraints
(append result (list choice))))))))))
(define std-tie-breaker
(lambda (get-supers)
(lambda (partial-cpl min-elts)
(let loop ((pcpl (reverse partial-cpl)))
(let ((current-elt (car pcpl)))
(let ((ds-of-ce (get-supers current-elt)))
(let ((common (collect-if (lambda (x)
(memq x ds-of-ce))
min-elts)))
(if (null? common)
(if (null? (cdr pcpl))
(error 'std-tie-breaker "Nothing valid")
(loop (cdr pcpl)))
(car common)))))))))
(define build-transitive-closure
(lambda (get-follow-ons)
(lambda (x)
(let track ((result '())
(pending (list x)))
(if (null? pending)
result
(let ((next (car pending)))
(if (memq next result)
(track result (cdr pending))
(track (cons next result)
(append (get-follow-ons next)
(cdr pending))))))))))
(define build-constraints
(lambda (get-follow-ons)
(lambda (x)
(let loop ((elements ((build-transitive-closure get-follow-ons) x))
(this-one '())
(result '()))
(if (or (null? this-one) (null? (cdr this-one)))
(if (null? elements)
result
(loop (cdr elements)
(cons (car elements)
(get-follow-ons (car elements)))
result))
(loop elements
(cdr this-one)
(cons (list (car this-one) (cadr this-one))
result)))))))

107
tiny-announce.text Normal file
View File

@ -0,0 +1,107 @@
This message will be of interest to: (i) People who are interested in
metaobject protocols, particularly metaobject protocols for Lisp-based
object-oriented languages; and (ii) people who are interested in Lisp-
based object-oriented languages like CLOS and Dylan. In this message,
we announce the public availability of the Scheme implementation of a
`kernelized' CLOS, with a metaobject protocol. (If you are interested
only in OO languages, and not metaobject protocols, you can skip the
third, fourth and fifth paragraphs of this message.)
One stumbling block for people interested in playing with the metaobject
protocol (MOP) ideas has been the relative complexity of working in
Common Lisp. This has been a particular obstacle for undergraduates and
others who normally work in Scheme (or a very reduced Common Lisp). To
try and address this, we have designed and implemented a Scheme
embedding of a core subset of CLOS, with a corresponding core MOP.
Since our primary goal is pedagogical in nature, we have been able to
produce an extremely lean language, MOP and implementation. The
implementation is even simpler than the simple CLOS found in `The Art of
the Metaobject Protocol,' weighing in at around 850 lines of code,
including (some) comments and documentation.
By making the new language and MOP be the core of CLOS and the CLOS MOP,
rather than some completely new language, our goal was to make possible
for people to work with existing written materials -- primarily `The Art
of the Metaobject Protocol' (AMOP) -- when playing with this system.
(It should also be possible for people working with Tiny CLOS to get
value from reading papers about others MOPs, such as ABLC/R, 3KRS and
others.) A side benefit of this approach is that Tiny CLOS is close to
a core of Dylan, so people interested in that language may find value in
playing with Tiny CLOS as well.)
The MOP in Tiny CLOS is very simple -- 8 introspective procedures and 9
intercessory generics -- but it retains much of the power of both of the
MOPs found in AMOP. Even though the Tiny CLOS implementation itself
isn't optimized, this MOP is amenable to optimization, using techniques
like those mentioned in AMOP. In fact, the slot access protocol used in
this MOP is such that it should be possible to get better performance
than is possible with the CLOS MOP.
While it isn't our primary goal, Tiny CLOS can also be used by those who
are simply intereted in CLOS/Dylan style OO languages. That is, you can
play with the base language without even thinking about the MOP. A
great deal has already been said and written about how to learn, think
about and teach OOP and CLOS-like languages, so we won't say any more
about that. But, it is important to point out a significant difference
between Tiny CLOS and CLOS/Dylan. In Tiny CLOS, slot names are not
required to be symbols, they can be any Scheme datum (object). (They
are compared using eq?.) This means that one can use the lexical
scoping mechanisms of Scheme to achieve a greater degree of
encapsulation than is possible in CLOS. For more on this, see the
second and third examples in the examples file.
Accompanying Tiny CLOS is a file of examples, that show how the base
language works, and how to use the MOP to do several common extensions.
Other things people might want to write are: before and after methods,
slot filling initargs, beta-like languages, singleton methods etc.
To make distribution simple, Tiny CLOS is available by anonymous ftp
from parcftp.xerox.com:/pub/mops. There are five files of interest:
tiny-annouce.text This message.
support.scm Just a bunch of useful stuff.
(All implementation specific mods (are supposed
to) go in here.)
tiny-clos.scm The main program.
tiny-examples.scm A few little examples of using this language
and this MOP.
tiny-rpp.text The reflective processor program for this
MOP. This file was generated, by hand, from
tiny-clos.scm by removing all the code that
deals with bootstrapping or grounding out
the tower. That is, this is the code/protocol
that you should `think of' as running at the
next level, when ignoring issues of circularity.
MIT Scheme 11.74 is the only Scheme we have access to, so that is the
only Scheme in which we have run this stuff. But, it should run with
only minor mods in other Schemes as well. (Please send us those mods
so they can be included in the sources!)
This language, this MOP, and this implementation should not be treated
as any sort of finished product. This whole thing was cranked out
relatively quickly, in response to an immediate need for simplified
Scheme embeddings of this stuff. We are very interested in any
suggestions or improvements you might have or make. So, please send
them in!
(It is also worth knowing that this is the first Scheme program I have
written in 10 years, so I'm willing to believe I have a lot to learn
about good Scheme style. Rather than just snickering, please let me
know about stupid things this code does in that regard.)
One other note. You will notice that these files have a copyright
notice on them, as is the fashion these days. It isn't copyleft, it is
somewhat more liberal than that. If you have any questions about it,
send us mail.
Finally, please let us know if you decide to play with this stuff, and
if you want to be on the mops@parc.xerox.com mailing list. (Note,
please don't use this mailing list for adminstrative stuff. It is for
technical questions and discussions. For administrative stuff, send
mail to Gregor@parc.xerox.com.)

885
tiny-clos.scm Normal file
View File

@ -0,0 +1,885 @@
; 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 Fixed bug in compute-method-more-specific?,
; wrt the use of for-each.
; Both methods on allocate instance failed to
; initialize fields properly.
; The specializers and procedure initargs are
; now required when creating a method, that is,
; they no longer default. No working program
; should notice this change.
; 1.2 12/02/92 Gregor Fix minor things that improve portability:
; - DEFINE needs 2 args in R4Rs
; - Conditionalize printer hooks.
; - () doesn't evaluate to ()
;
; 1.3 12/08/92 Gregor More minor things:
; - () really doesn't evaluate to () damnit!
; - It turns out DEFINE-MACRO is never used.
; - Confusion over the "failure" return value
; of ASSQ -- ASSQ returns #f if the key is
; not found.
; - SEQUENCE --> BEGIN
; - LAST-PAIR --> last now in support
; Change instance rep to protect Schemes that
; don't detect circular structures when
; printing.
; A more reasonable error message when there
; are no applicable methods or next methods.
; 1.4 12/10/92 Gregor Flush filter-in for collect-if. Add news
; classes <input-port> and <output-port>.
; Also add
;
; 1.5 12/17/92 Gregor Minor changes to class of and primitive
; classes to try and deal with '() and #f
; better.
;
; 1.6 9/9/93 Gregor Fix a monstrous bug in the bootstrap of
; compute-apply-generic which sometimes ran
; user methods on this generic function when
; it shouldn't.
;
; 1.7 8/9/94 Gregor Add Scheme 48 to support.scm.
;
;
;
(define tiny-clos-version "1.7")
'(;Stuff to make emacs more reasonable.
(put 'letrec 'lisp-indent-hook 1)
(put 'make-method 'lisp-indent-hook 1)
(put 'add-method 'lisp-indent-hook 'defun)
)
;
; 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-OF
;
; 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
;
;
; OK, now let's get going. But, as usual, before we can do anything
; interesting, we have to muck around for a bit first. First, we need
; to load the support library.
;
; Note that there is no extension on the filename in the following load,
; in particular, it isn't "support.scm" even though that is the name of
; the file in the distribution at PARC. The idea is that when people
; install the code at their site, they should rename all the files to
; the appropriate extension, and then not change the load. This should
; also make things work with binary files and the like. This comes from
; my understanding of the CL world... I hope it is right.
;
;
(load "support")
;
; Then, we need to build what, in a more real implementation, would be
; the interface to the memory subsystem: instances and entities. The
; former are used for instances of instances of <class>; the latter
; are used for instances of instances of <entity-class>. In this MOP,
; none of this is visible to base- or MOP-level programmers.
;
; A few things to note, that have influenced the way all this is done:
;
; - R4RS doesn't provide a mechanism for specializing the
; behavior of the printer for certain objects.
;
; - Some Scheme implementations bomb when printing circular
; structures -- that is, arrays and/or lists that somehow
; point back to themselves.
;
; So, the natural implementation of instances -- vectors whose first
; field point to the class -- is straight on out. Instead, we use a
; procedure to `encapsulate' that natural representation.
;
; Having gone that far, it makes things simpler to unify the way normal
; instances and entities are handled, at least in the lower levels of
; the system. Don't get faked out by this -- the user shouldn't think
; of normal instances as being procedures, they aren't. (At least not
; in this language.) If you are using this to teach, you probably want
; to hide the implementation of instances and entities from people.
;
;
(define %allocate-instance
(lambda (class nfields)
(%allocate-instance-internal
class
#t
(lambda args
(error "An instance isn't a procedure -- can't apply it."))
nfields)))
(define %allocate-entity
(lambda (class nfields)
(%allocate-instance-internal
class
#f
(lambda args
(error "Tried to call an entity before its proc is set."))
nfields)))
(define %allocate-instance-internal ???)
(define %instance? ???)
(define %instance-class ???)
(define %set-instance-class-to-self ???) ;This is used only once
;as part of bootstrapping
;the braid.
(define %set-instance-proc! ???)
(define %instance-ref ???)
(define %instance-set! ???)
(letrec ((instances '())
(get-vector
(lambda (closure)
(let ((cell (assq closure instances)))
(if cell (cdr cell) #f)))))
(set! %allocate-instance-internal
(lambda (class lock proc nfields)
(letrec ((vector (make-vector (+ nfields 3) #f))
(closure (lambda args
(apply (vector-ref vector 0) args))))
(vector-set! vector 0 proc)
(vector-set! vector 1 lock)
(vector-set! vector 2 class)
(set! instances (cons (cons closure vector) instances))
closure)))
(set! %instance?
(lambda (x) (not (null? (get-vector x)))))
(set! %instance-class
(lambda (closure)
(let ((vector (get-vector closure)))
(vector-ref vector 2))))
(set! %set-instance-class-to-self
(lambda (closure)
(let ((vector (get-vector closure)))
(vector-set! vector 2 closure))))
(set! %set-instance-proc!
(lambda (closure proc)
(let ((vector (get-vector closure)))
(if (vector-ref vector 1)
(error "Can't set procedure of instance.")
(vector-set! vector 0 proc)))))
(set! %instance-ref
(lambda (closure index)
(let ((vector (get-vector closure)))
(vector-ref vector (+ index 3)))))
(set! %instance-set!
(lambda (closure index new-value)
(let ((vector (get-vector closure)))
(vector-set! vector (+ index 3) new-value))))
)
;
; %allocate-instance, %allocate-entity, %instance-ref, %instance-set!
; and class-of are the normal interface, from the rest of the code, to
; the low-level memory system. One thing to take note of is that the
; protocol does not allow the user to add low-level instance
; representations. I have never seen a way to make that work.
;
; Note that this implementation of class-of assumes the name of a the
; primitive classes that are set up later.
;
(define class-of
(lambda (x)
(cond ((%instance? x) (%instance-class x))
((pair? x) <pair>) ;If all Schemes were IEEE
((null? x) <null>) ;compliant, the order of
((boolean? x) <boolean>) ;these wouldn't matter?
((symbol? x) <symbol>)
((procedure? x) <procedure>)
((number? x) <number>)
((vector? x) <vector>)
((char? x) <char>)
((string? x) <string>)
(( input-port? x) <input-port>)
((output-port? x) <output-port>)
)))
;
; Now we can get down to business. First, we initialize the braid.
;
; For Bootstrapping, we define an early version of MAKE. It will be
; changed to the real version later on. String search for ``set! make''.
;
(define make
(lambda (class . initargs)
(cond ((or (eq? class <class>)
(eq? class <entity-class>))
(let* ((new (%allocate-instance
class
(length the-slots-of-a-class)))
(dsupers (getl initargs 'direct-supers '()))
(dslots (map list
(getl initargs 'direct-slots '())))
(cpl (let loop ((sups dsupers)
(so-far (list new)))
(if (null? sups)
(reverse so-far)
(loop (class-direct-supers
(car sups))
(cons (car sups)
so-far)))))
(slots (apply append
(cons dslots
(map class-direct-slots
(cdr cpl)))))
(nfields 0)
(field-initializers '())
(allocator
(lambda (init)
(let ((f nfields))
(set! nfields (+ nfields 1))
(set! field-initializers
(cons init field-initializers))
(list (lambda (o) (%instance-ref o f))
(lambda (o n) (%instance-set! o f n))))))
(getters-n-setters
(map (lambda (s)
(cons (car s)
(allocator (lambda () '()))))
slots)))
(slot-set! new 'direct-supers dsupers)
(slot-set! new 'direct-slots dslots)
(slot-set! new 'cpl cpl)
(slot-set! new 'slots slots)
(slot-set! new 'nfields nfields)
(slot-set! new 'field-initializers (reverse
field-initializers))
(slot-set! new 'getters-n-setters getters-n-setters)
new))
((eq? class <generic>)
(let ((new (%allocate-entity class
(length (class-slots class)))))
(slot-set! new 'methods '())
new))
((eq? class <method>)
(let ((new (%allocate-instance
class
(length (class-slots class)))))
(slot-set! new
'specializers
(getl initargs 'specializers))
(slot-set! new
'procedure
(getl initargs 'procedure))
new)))))
;
; These are the real versions of slot-ref and slot-set!. Because of the
; way the new slot access protocol works, with no generic call in line,
; they can be defined up front like this. Cool eh?
;
;
(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
(if (eq? class <class>) ;* This grounds out
getters-n-setters-for-class ;* the slot-ref tower.
(slot-ref class 'getters-n-setters)))
(entry (assq slot-name getters-n-setters)))
(if entry
(cdr entry)
(error "No slot" slot-name "in instances of" class)))))
;
; Given that the early version of MAKE is allowed to call accessors on
; class metaobjects, the definitions for them come here, before the
; actual class definitions, which are coming up right afterwards.
;
;
(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 next 7 clusters define the 6 initial classes. It takes 7 to 6
; because the first and fourth both contribute to <class>.
;
(define the-slots-of-a-class ;
'(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 getters-n-setters-for-class ;see lookup-slot-info
;
; I know this seems like a silly way to write this. The
; problem is that the obvious way to write it seems to
; tickle a bug in MIT Scheme!
;
(let ((make-em (lambda (s f)
(list s
(lambda (o) (%instance-ref o f))
(lambda (o n) (%instance-set! o f n))))))
(map (lambda (s)
(make-em s (position-of s the-slots-of-a-class)))
the-slots-of-a-class)))
(define <class> (%allocate-instance #f (length the-slots-of-a-class)))
(%set-instance-class-to-self <class>)
(define <top> (make <class>
'direct-supers (list)
'direct-slots (list)))
(define <object> (make <class>
'direct-supers (list <top>)
'direct-slots (list)))
;
; This cluster, together with the first cluster above that defines
; <class> and sets its class, have the effect of:
;
; (define <class>
; (make <class>
; 'direct-supers (list <object>)
; 'direct-slots (list 'direct-supers ...)))
;
(slot-set! <class> 'direct-supers (list <object>))
(slot-set! <class> 'direct-slots (map list the-slots-of-a-class))
(slot-set! <class> 'cpl (list <class> <object> <top>))
(slot-set! <class> 'slots (map list the-slots-of-a-class))
(slot-set! <class> 'nfields (length the-slots-of-a-class))
(slot-set! <class> 'field-initializers (map (lambda (s)
(lambda () '()))
the-slots-of-a-class))
(slot-set! <class> 'getters-n-setters '())
(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)))
;
; These are the convenient syntax we expose to the base-level user.
;
;
(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)))
;
; 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))
;
; The next thing to do is bootstrap generic functions.
;
(define generic-invocation-generics (list compute-apply-generic
compute-methods
compute-method-more-specific?
compute-apply-methods))
(define add-method
(lambda (generic method)
(slot-set! generic
'methods
(cons method
(collect-if
(lambda (m)
(not (every eq?
(method-specializers m)
(method-specializers method))))
(slot-ref generic 'methods))))
(%set-instance-proc! generic (compute-apply-generic generic))))
;
; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls
; the other generics in the generic invocation protocol. Two, related,
; problems come up. A chicken and egg problem and a infinite regress
; problem.
;
; In order to add our first method to COMPUTE-APPLY-GENERIC, we need
; something sitting there, so it can be called. The first definition
; below does that.
;
; Then, the second definition solves both the infinite regress and the
; not having enough of the protocol around to build itself problem the
; same way: it special cases invocation of generics in the invocation
; protocol.
;
;
(%set-instance-proc! compute-apply-generic
(lambda (generic)
(let ((method (car (generic-methods generic))))
((method-procedure method) #f generic))))
(add-method compute-apply-generic
(make-method (list <generic>)
(lambda (call-next-method generic)
(lambda args
(if (and (memq generic generic-invocation-generics) ;* G c
(memq (car args) generic-invocation-generics)) ;* r a
(apply (method-procedure ;* o s
(last (generic-methods generic))) ;* u e
(cons #f args)) ;* n
;* d
((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
(collect-if (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 ((and (null? specls1) (null? specls2))
(error
"Two methods are equally specific."))
((or (null? specls1) (null? specls2))
(error
"Two methods have a different number of specializers."))
((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))))))))))
(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)))))))
(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 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) (%instance-ref o f))
(lambda (o n) (%instance-set! 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-instance-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
(%instance-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 () '())))))
;
; Now everything works, both generic functions and classes, so we can
; turn on the real MAKE.
;
;
(set! make
(lambda (class . initargs)
(let ((instance (allocate-instance class)))
(initialize instance initargs)
instance)))
;
; Now define what CLOS calls `built in' classes.
;
;
(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 <pair> (make-primitive-class))
(define <null> (make-primitive-class))
(define <symbol> (make-primitive-class))
(define <boolean> (make-primitive-class))
(define <procedure> (make-primitive-class <procedure-class>))
(define <number> (make-primitive-class))
(define <vector> (make-primitive-class))
(define <char> (make-primitive-class))
(define <string> (make-primitive-class))
(define <input-port> (make-primitive-class))
(define <output-port> (make-primitive-class))
;
; All done.
;
;
'tiny-clos-up-and-running

361
tiny-examples.scm Normal file
View File

@ -0,0 +1,361 @@
; 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.
; **********************************************************************
;
; Some simple examples of using Tiny CLOS and its MOP.
;
; Much of this stuff corresponds to stuff in AMOP (The Art of the
; Metaobject Protocol).
;
;***
;
; This is a useful sort of helper function. Note how it uses the
; introspective part of the MOP. The first few pages of chapter
; two of the AMOP discuss this.
;
; Note that this introspective MOP doesn't support back-links from
; the classes to methods and generic functions. Is that worth adding?
;
;
(define initialize-slots
(lambda (object initargs)
(let ((not-there (list 'shes-not-there)))
(for-each (lambda (slot)
(let ((name (car slot)))
(let ((value (getl initargs name not-there)))
(if (eq? value not-there)
'do-nothing
(slot-set! object name value)))))
(class-slots (class-of object))))))
;***
;
; A simple class, just an instance of <class>. Note that we are using
; make and <class> rather than make-class to make it. See Section 2.4
; of AMOP for more on this.
;
;
(define <pos> (make <class> ;[make-class
'direct-supers (list <object>) ; (list <object>)
'direct-slots (list 'x 'y))) ; (list 'x 'y)]
(add-method initialize
(make-method (list <pos>)
(lambda (call-next-method pos initargs)
(call-next-method)
(initialize-slots pos initargs))))
(define p1 (make <pos> 'x 1 'y 2))
(define p2 (make <pos> 'x 3 'y 5))
;***
;
; Another way of writing that class definition, that achives better
; `encapsulation' by using slot names that are unique keys, rather
; than symbols.
;
;
(define <pos>)
(define pos-x (make-generic))
(define pos-y (make-generic))
(define move (make-generic))
(let ((x (vector 'x))
(y (vector 'y)))
(set! <pos> (make <class>
'direct-supers (list <object>)
'direct-slots (list x y)))
(add-method pos-x
(make-method (list <pos>)
(lambda (call-next-method pos) (slot-ref pos x))))
(add-method pos-y
(make-method (list <pos>)
(lambda (call-next-method pos) (slot-ref pos y))))
(add-method move
(make-method (list <pos>)
(lambda (call-next-method pos new-x new-y)
(slot-set! pos x new-x)
(slot-set! pos y new-y))))
(add-method initialize
(make-method (list <pos>)
(lambda (call-next-method pos initargs)
(move pos (getl initargs 'x 0) (getl initargs 'y 0)))))
)
(define p3 (make <pos> 'x 1 'y 2))
(define p4 (make <pos> 'x 3 'y 5))
;***
;
; Class allocated slots.
;
; In Scheme, this extension isn't worth a whole lot, but what the hell.
;
;
(define <class-slots-class>
(make-class (list <class>)
(list)))
(add-method compute-getter-and-setter
(make-method (list <class-slots-class>)
(lambda (call-next-method class slot allocator)
(if (null? (memq ':class-allocation slot))
(call-next-method)
(let ((cell '()))
(list (lambda (o) cell)
(lambda (o new) (set! cell new) new)))))))
;
; Here's a silly program that uses class allocated slots.
;
;
(define <ship>
(make <class-slots-class>
'direct-supers (list <object>)
'direct-slots (list 'name
'(all-ships :class-allocation))))
(add-method initialize
(make-method (list <ship>)
(lambda (call-next-method ship initargs)
(call-next-method)
(initialize-slots ship initargs)
(slot-set! ship
'all-ships
(cons ship (slot-ref ship 'all-ships))))))
(define siblings (make-generic))
(add-method siblings
(make-method (list <ship>)
(lambda (call-next-method ship)
(remove ship (slot-ref ship 'all-ships)))))
(define s1 (make <ship> 'name 's1))
(define s2 (make <ship> 'name 's2))
(define s3 (make <ship> 'name 's3))
;***
;
; Here's a class of class that allocates some slots dynamically.
;
; It has a layered protocol (dynamic-slot?) that decides whether a given
; slot should be dynamically allocated. This makes it easy to define a
; subclass that allocates all its slots dynamically.
;
;
(define <dynamic-class>
(make-class (list <class>)
(list 'alist-g-n-s)))
(define dynamic-slot? (make-generic))
(add-method dynamic-slot?
(make-method (list <dynamic-class>)
(lambda (call-next-method class slot)
(memq :dynamic-allocation (cdr slot)))))
(define alist-getter-and-setter
(lambda (dynamic-class allocator)
(let ((old (slot-ref dynamic-class 'alist-g-n-s)))
(if (null? old)
(let ((new (allocator (lambda () '()))))
(slot-set! dynamic-class 'alist-g-n-s new)
new)
old))))
(add-method compute-getter-and-setter
(make-method (list <dynamic-class>)
(lambda (call-next-method class slot allocator)
(if (null? (dynamic-slot? class slot))
(call-next-method)
(let* ((name (car slot))
(g-n-s (alist-getter-and-setter class allocator))
(alist-getter (car g-n-s))
(alist-setter (cadr g-n-s)))
(list (lambda (o)
(let ((entry (assq name (alist-getter o))))
(if (null? entry)
'()
(cdr entry))))
(lambda (o new)
(let* ((alist (alist-getter o))
(entry (assq name alist)))
(if (null? entry)
(alist-setter o
(cons (cons name new) alist))
(set-cdr! entry new))
new))))))))
(define <all-dynamic-class>
(make-class (list <dynamic-class>)
(list)))
(add-method dynamic-slot?
(make-method (list <all-dynamic-class>)
(lambda (call-next-method class slot) #t)))
;
; A silly program that uses this.
;
;
(define <person> (make <all-dynamic-class>
'direct-supers (list <object>)
'direct-slots (list 'name 'age 'address)))
(add-method initialize
(make-method (list <person>)
(lambda (call-next-method person initargs)
(initialize-slots person initargs))))
(define person1 (make <person> 'name 'sally))
(define person2 (make <person> 'name 'betty))
(define person3 (make <person> 'name 'sue))
;***
;
; A ``database'' class that stores slots externally.
;
;
(define <db-class>
(make-class (list <class>)
(list 'id-g-n-s)))
(define id-getter-and-setter
(lambda (db-class allocator)
(let ((old (slot-ref db-class 'id-g-n-s)))
(if (null? old)
(let ((new (allocator db-allocate-id)))
(slot-set! class 'id-g-n-s new)
new)
old))))
(add-method compute-getter-and-setter
(make-method (list <db-class>)
(lambda (call-next-method class slot allocator)
(let* ((id-g-n-s (id-getter-and-setter class allocator))
(id-getter (car id-g-n-s))
(id-setter (cadr id-g-n-s))
(slot-name (car slot)))
(list (lambda (o)
(db-lookup (id-getter o) slot-name))
(lambda (o new)
(db-store (id-getter o) slot-name new)))))))
;***
;
; A kind of generic that supports around methods.
;
;
(define make-around-generic
(lambda () (make <around-generic>)))
(define make-around-method
(lambda (specializers procedure)
(make <around-method>
'specializers specializers
'procedure procedure)))
(define <around-generic> (make <entity-class>
'direct-supers (list <generic>)))
(define <around-method> (make <class>
'direct-supers (list <method>)))
(define around-method? (make-generic))
(add-method around-method?
(make-method (list <method>)
(lambda (call-next-method x) #f)))
(add-method around-method?
(make-method (list <around-method>)
(lambda (call-next-method x) #t)))
(add-method compute-methods
(make-method (list <around-generic>)
(lambda (call-next-method generic)
(let ((normal-compute-methods (call-next-method)))
(lambda (args)
(let ((normal-methods (normal-compute-methods args)))
(append
(filter-in around-method?
normal-methods)
(filter-in (lambda (m) (not (around-method? m)))
normal-methods))))))))
;
; And a simple example of using it.
;
;
(define <baz> (make-class (list <object>) (list)))
(define <bar> (make-class (list <baz>) (list)))
(define <foo> (make-class (list <bar>) (list)))
(define test-around
(lambda (generic)
(add-method generic
(make-method (list <foo>)
(lambda (cnm x) (cons 'foo (cnm)))))
(add-method generic
(make-around-method (list <bar>)
(lambda (cnm x) (cons 'bar (cnm)))))
(add-method generic
(make-method (list <baz>)
(lambda (cnm x) '(baz))))
(generic (make <foo>))))
(equal? (test-around (make-generic)) '(foo bar baz))
(equal? (test-around (make-around-generic)) '(bar foo baz))

523
tiny-rpp.text Normal file
View File

@ -0,0 +1,523 @@
; 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)))