From 320c3aacd5b2e652c8e4b3fa7c47e51211a1f449 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 1 Jul 2023 09:38:05 +0300 Subject: [PATCH] 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 --- support.scm | 257 +++++++++++++ tiny-announce.text | 107 ++++++ tiny-clos.scm | 885 +++++++++++++++++++++++++++++++++++++++++++++ tiny-examples.scm | 361 ++++++++++++++++++ tiny-rpp.text | 523 +++++++++++++++++++++++++++ 5 files changed, 2133 insertions(+) create mode 100644 support.scm create mode 100644 tiny-announce.text create mode 100644 tiny-clos.scm create mode 100644 tiny-examples.scm create mode 100644 tiny-rpp.text diff --git a/support.scm b/support.scm new file mode 100644 index 0000000..3d442bf --- /dev/null +++ b/support.scm @@ -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 . +; +; + +(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))))))) diff --git a/tiny-announce.text b/tiny-announce.text new file mode 100644 index 0000000..b78f6ff --- /dev/null +++ b/tiny-announce.text @@ -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.) diff --git a/tiny-clos.scm b/tiny-clos.scm new file mode 100644 index 0000000..210a464 --- /dev/null +++ b/tiny-clos.scm @@ -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 and . +; 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 (make-class (list ) (list 'x 'y))) +; (add-method initialize +; (make-method (list ) +; (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 '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 ; the latter +; are used for instances of instances of . 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) ) ;If all Schemes were IEEE + ((null? x) ) ;compliant, the order of + ((boolean? x) ) ;these wouldn't matter? + ((symbol? x) ) + ((procedure? x) ) + ((number? x) ) + ((vector? x) ) + ((char? x) ) + ((string? x) ) + (( input-port? x) ) + ((output-port? x) ) + + + ))) + + +; +; 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 ) + (eq? 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 ) + (let ((new (%allocate-entity class + (length (class-slots class))))) + (slot-set! new 'methods '()) + new)) + ((eq? class ) + (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 ) ;* 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 . +; +(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 (%allocate-instance #f (length the-slots-of-a-class))) +(%set-instance-class-to-self ) + +(define (make + 'direct-supers (list) + 'direct-slots (list))) + +(define (make + 'direct-supers (list ) + 'direct-slots (list))) + +; +; This cluster, together with the first cluster above that defines +; and sets its class, have the effect of: +; +; (define +; (make +; 'direct-supers (list ) +; 'direct-slots (list 'direct-supers ...))) +; +(slot-set! 'direct-supers (list )) +(slot-set! 'direct-slots (map list the-slots-of-a-class)) +(slot-set! 'cpl (list )) +(slot-set! 'slots (map list the-slots-of-a-class)) +(slot-set! 'nfields (length the-slots-of-a-class)) +(slot-set! 'field-initializers (map (lambda (s) + (lambda () '())) + the-slots-of-a-class)) +(slot-set! 'getters-n-setters '()) + + +(define (make + 'direct-supers (list ) + 'direct-slots (list))) + +(define (make + 'direct-supers (list ) + 'direct-slots (list))) + +(define (make + 'direct-supers (list ) + 'direct-slots (list 'methods))) + +(define (make + 'direct-supers (list ) + '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 + 'direct-supers direct-supers + 'direct-slots direct-slots))) + +(define make-generic + (lambda () + (make ))) + +(define make-method + (lambda (specializers procedure) + (make + '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 ) + (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 ) + (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 ) + (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 ) + (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 ) + (lambda (call-next-method object initargs) object))) + +(add-method initialize + (make-method (list ) + (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 ) + (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 ) + (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 ) + (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 ) + (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 ) + (lambda (call-next-method class) + (compute-std-cpl class class-direct-supers)))) + + +(add-method compute-slots + (make-method (list ) + (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 ) + (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 + (make + 'direct-supers (list ) + 'direct-slots (list))) + +(define make-primitive-class + (lambda class + (make (if (null? class) (car class)) + 'direct-supers (list ) + 'direct-slots (list)))) + + +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class )) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) + + +; +; All done. +; +; + +'tiny-clos-up-and-running diff --git a/tiny-examples.scm b/tiny-examples.scm new file mode 100644 index 0000000..e5bd421 --- /dev/null +++ b/tiny-examples.scm @@ -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 . Note that we are using +; make and rather than make-class to make it. See Section 2.4 +; of AMOP for more on this. +; +; + +(define (make ;[make-class + 'direct-supers (list ) ; (list ) + 'direct-slots (list 'x 'y))) ; (list 'x 'y)] + +(add-method initialize + (make-method (list ) + (lambda (call-next-method pos initargs) + (call-next-method) + (initialize-slots pos initargs)))) + +(define p1 (make 'x 1 'y 2)) +(define p2 (make '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 ) +(define pos-x (make-generic)) +(define pos-y (make-generic)) +(define move (make-generic)) + +(let ((x (vector 'x)) + (y (vector 'y))) + + (set! (make + 'direct-supers (list ) + 'direct-slots (list x y))) + + (add-method pos-x + (make-method (list ) + (lambda (call-next-method pos) (slot-ref pos x)))) + (add-method pos-y + (make-method (list ) + (lambda (call-next-method pos) (slot-ref pos y)))) + + (add-method move + (make-method (list ) + (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 ) + (lambda (call-next-method pos initargs) + (move pos (getl initargs 'x 0) (getl initargs 'y 0))))) + ) + + +(define p3 (make 'x 1 'y 2)) +(define p4 (make 'x 3 'y 5)) + + +;*** +; +; Class allocated slots. +; +; In Scheme, this extension isn't worth a whole lot, but what the hell. +; +; + +(define + (make-class (list ) + (list))) + +(add-method compute-getter-and-setter + (make-method (list ) + (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 + (make + 'direct-supers (list ) + 'direct-slots (list 'name + '(all-ships :class-allocation)))) + +(add-method initialize + (make-method (list ) + (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 ) + (lambda (call-next-method ship) + (remove ship (slot-ref ship 'all-ships))))) + +(define s1 (make 'name 's1)) +(define s2 (make 'name 's2)) +(define s3 (make '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 + (make-class (list ) + (list 'alist-g-n-s))) + + +(define dynamic-slot? (make-generic)) + +(add-method dynamic-slot? + (make-method (list ) + (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 ) + (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 + (make-class (list ) + (list))) + +(add-method dynamic-slot? + (make-method (list ) + (lambda (call-next-method class slot) #t))) + + + +; +; A silly program that uses this. +; +; +(define (make + 'direct-supers (list ) + 'direct-slots (list 'name 'age 'address))) + +(add-method initialize + (make-method (list ) + (lambda (call-next-method person initargs) + (initialize-slots person initargs)))) + + +(define person1 (make 'name 'sally)) +(define person2 (make 'name 'betty)) +(define person3 (make 'name 'sue)) + + +;*** +; +; A ``database'' class that stores slots externally. +; +; + +(define + (make-class (list ) + (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 ) + (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 ))) + +(define make-around-method + (lambda (specializers procedure) + (make + 'specializers specializers + 'procedure procedure))) + + +(define (make + 'direct-supers (list ))) +(define (make + 'direct-supers (list ))) + + +(define around-method? (make-generic)) + +(add-method around-method? + (make-method (list ) + (lambda (call-next-method x) #f))) +(add-method around-method? + (make-method (list ) + (lambda (call-next-method x) #t))) + + +(add-method compute-methods + (make-method (list ) + (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 (make-class (list ) (list))) +(define (make-class (list ) (list))) +(define (make-class (list ) (list))) + + +(define test-around + (lambda (generic) + (add-method generic + (make-method (list ) + (lambda (cnm x) (cons 'foo (cnm))))) + + (add-method generic + (make-around-method (list ) + (lambda (cnm x) (cons 'bar (cnm))))) + + (add-method generic + (make-method (list ) + (lambda (cnm x) '(baz)))) + + (generic (make )))) + + +(equal? (test-around (make-generic)) '(foo bar baz)) +(equal? (test-around (make-around-generic)) '(bar foo baz)) diff --git a/tiny-rpp.text b/tiny-rpp.text new file mode 100644 index 0000000..2e153a6 --- /dev/null +++ b/tiny-rpp.text @@ -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 (make-class (list ) (list 'x 'y))) +; (add-method initialize +; (make-method (list ) +; (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 '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 (make + 'direct-supers (list) + 'direct-slots (list))) + +(define (make + 'direct-supers (list ) + 'direct-slots (list))) + +(define + (make + 'direct-supers (list ) + '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 + (make + 'direct-supers (list ) + 'direct-slots (list))) + +(define make-primitive-class + (lambda class + (make (if (null? class) (car class)) + 'direct-supers (list ) + 'direct-slots (list)))) + +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class)) +(define (make-primitive-class )) + + +(define (make + 'direct-supers (list ) + 'direct-slots (list))) + +(define (make + 'direct-supers (list ) + 'direct-slots (list))) + +(define (make + 'direct-supers (list ) + 'direct-slots (list 'methods))) + +(define (make + 'direct-supers (list ) + '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 ) + (lambda (call-next-method object initargs) object))) + +(add-method initialize + (make-method (list ) + (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 ) + (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 ) + (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 ) + (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 ) + (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 ) + (lambda (call-next-method class) + (compute-std-cpl class class-direct-supers)))) + + +(add-method compute-slots + (make-method (list ) + (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 ) + (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 ) + (lambda (call-next-method generic) + (lambda args + ((compute-apply-methods generic) + ((compute-methods generic) args) + args))))) + +(add-method compute-methods + (make-method (list ) + (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 ) + (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 ) + (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 + 'direct-supers direct-supers + 'direct-slots direct-slots))) + +(define make-generic + (lambda () + (make ))) + +(define make-method + (lambda (specializers procedure) + (make + 'specializers specializers + 'procedure procedure))) + +