From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Michael Tiedtke Newsgroups: gmane.lisp.guile.user Subject: Re: Message Passing with GOOPS Date: Thu, 25 Jun 2015 12:59:30 +0200 Message-ID: <558BDF12.9000502@o2online.de> References: <558B1158.4020607@o2online.de> <87mvzolpzi.fsf@elektro.pacujo.net> <558BA01C.9070208@o2online.de> <87pp4kxijl.fsf@elektro.pacujo.net> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="------------030903020306090903020801" X-Trace: ger.gmane.org 1435230031 25212 80.91.229.3 (25 Jun 2015 11:00:31 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 25 Jun 2015 11:00:31 +0000 (UTC) Cc: "guile-user@gnu.org" Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Thu Jun 25 13:00:23 2015 Return-path: Envelope-to: guile-user@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1Z84tJ-0005CG-D6 for guile-user@m.gmane.org; Thu, 25 Jun 2015 13:00:22 +0200 Original-Received: from localhost ([::1]:54957 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z84tI-0007NQ-Uh for guile-user@m.gmane.org; Thu, 25 Jun 2015 07:00:20 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:59901) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z84sw-00079f-Kc for guile-user@gnu.org; Thu, 25 Jun 2015 07:00:05 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Z84ss-0008T7-Cn for guile-user@gnu.org; Thu, 25 Jun 2015 06:59:58 -0400 Original-Received: from mail226c50.megamailservers.eu ([91.136.10.236]:40150 helo=mail36c50.megamailservers.eu) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Z84sr-0008Pm-Uv for guile-user@gnu.org; Thu, 25 Jun 2015 06:59:54 -0400 X-Authenticated-User: michele.titke.o2online.de Original-Received: from [10.186.174.193] ([89.204.139.193]) (authenticated bits=0) by mail36c50.megamailservers.eu (8.14.9/8.13.1) with ESMTP id t5PAxWvN015504 for ; Thu, 25 Jun 2015 10:59:37 +0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.6.0 In-Reply-To: <87pp4kxijl.fsf@elektro.pacujo.net> X-CTCH-RefID: str=0001.0A020206.558BDF26.0167, ss=1, re=0.000, recu=0.000, reip=0.000, cl=1, cld=1, fgs=0 X-CTCH-VOD: Unknown X-CTCH-Spam: Unknown X-CTCH-Score: 0.000 X-CTCH-Rules: X-CTCH-Flags: 0 X-CTCH-ScoreCust: 0.000 X-CSC: 0 X-CHA: v=2.1 cv=CuSGLBID c=1 sm=1 tr=0 a=H6eTsslEdEH8ia2oUXC1vw==:117 a=H6eTsslEdEH8ia2oUXC1vw==:17 a=9cW_t1CCXrUA:10 a=FurB0epzNeMA:10 a=r77TgQKjGQsHNAKrUKIA:9 a=9iDbn-4jx3cA:10 a=cKsnjEOsciEA:10 a=gZbpxnkM3yUA:10 a=Gz7s5_CCAAAA:8 a=rOCdUwsm5a8Lbm50WfMA:9 a=pILNOxqGKmIA:10 a=FqOJaASz0BoA:10 a=KaybevnVAAAA:8 a=ZekQhpFi4FbVL-rPr8cA:9 a=z1pBEcaV0SLWnPIq:21 a=_W_S_7VecoQA:10 a=dVNa4OotiLBXwEnH4TQA:9 a=dMrmsVfnDHMu8i_E:21 a=eLI-VMECMqPBx3yP:21 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x (no timestamps) [generic] X-Received-From: 91.136.10.236 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Original-Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.user:11868 Archived-At: This is a multi-part message in MIME format. --------------030903020306090903020801 Content-Type: multipart/alternative; boundary="------------040701010300090304060906" --------------040701010300090304060906 Content-Type: text/plain; charset=windows-1252; format=flowed Content-Transfer-Encoding: 7bit On 25/06/2015 11:07, Marko Rauhamaa wrote: > Michael Tiedtke : > >> Nice! What about (define-class () ...)? In GOOPS every >> primitive type is (or should be) a class that can be used with >> multiple inheritance. It's enough to (use-modules (oop goops)). > My "simpleton" doesn't have classes. It's *object* oriented, not *class* > oriented. That reminds me of one chapter of /Structure and Interpretation of Computer Programs/: /Modularity, Objects, and State/ (https://mitpress.mit.edu/sicp/full-text/book/book-Z-H-19.html#%_chap_3) which comes right after /Systems with Generic Operations/. My current references to step ahead and not get stuck include TinyCLOS. GOOPS is - according to the documentation - inspired by it. The nice thing about it is this: it's 886 lines of Scheme code in one file which can be distributed (see below). For now I think I will do w/o message passing as GOOPS' /define-class/ is one long /letrec/ and of treating Scheme code as s-expressions with /cdddr/s. But with it's MOP / class system I can finally try to design an application framework with multiple inheritance. RIght now I have three distinct classes plus a "flat" controller: , , where buffer denotes a text file buffer because it's about a text editor. As the needed functionality and structure is building up I can already see has to "shadow" a lot of the functionality from both and and it might turn out that it's hard to keep them synchronized. Let's take for example the generic /cursor-up/. The is dumb and let's you call it as often as you want but it (the underlying VT) keeps the cursor on the screen. Now needs a method /cursor-up/, too. It has to make sure it stays in the current region of the buffer on screen and it has to call /cursor-up/ for explicitly or scroll the content or beep etc. With multiple inheritance it should be enough to call next-method at the right moment because any real programmable vi needs an incorporated Snake game (often called Nibbles) to remind people of Viper and the Virtual Terminal era and the Visual Display Editor. TinyCLOS ; ********************************************************************** ; 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. ; ********************************************************************** --------------040701010300090304060906 Content-Type: text/html; charset=windows-1252 Content-Transfer-Encoding: quoted-printable X-MIME-Autoconverted: from 8bit to quoted-printable by mail36c50.megamailservers.eu id t5PAxWvN015504

On 25/06/2015 11:07, Marko Rauhamaa wrote:
Michael Tiedtke <michele.titke@o2online.de>=
;:


Nice! What about (define-class <stack> (<=
list>) ...)? In GOOPS every
primitive type is (or should be) a class that can be used with
multiple inheritance. It's enough to (use-modules (oop goops)).

My "simpleton" doesn't have classes. It's *object* oriented, not *class*
oriented.

That reminds me of one chapter of Structure and Interpretation of Computer Programs:
Modularity, Objects, and State (https://mitpress.mit.edu/s= icp/full-text/book/book-Z-H-19.html#%_chap_3)
which comes right after Systems with Generic Operations.

My current references to step ahead and not get stuck include TinyCLOS. GOOPS is - according to the documentation - inspired by it. The nice thing about it is this: it's 886 lines of Scheme code in one file which can be distributed (see below).

For now I think I will do w/o message passing as GOOPS' define-cla= ss is one long letrec and of treating Scheme code as s-expressions with cdddrs. But with it's MOP / class system I can finally try to design an application framework with multiple inheritance.

RIght now I have three distinct classes plus a "flat" controller: <terminal>, <buffer-view>, <buffer> where buffer denotes a text file buffer because it's about a text editor. As the needed functionality and structure is building up I can already see <buffer-view> has to "shadow" a lot of the functionality from both <terminal> and <buffer> and it might turn out that it's hard to keep them synchronized. Let's take for example the generic cursor-up. The <terminal> is dumb and let's you call it as often as you want but it (the underlying VT) keeps the cursor on the screen. Now <buffer-view> needs a method c= ursor-up, too. It has to make sure it stays in the current region of the buffer on screen and it has to call cursor-up for <terminal> explicitly or scroll the content or beep etc.

With multiple inheritance it should be enough to call next-method at the right moment because any real programmable vi needs an incorporated Snake game (often called Nibbles) to remind people of Viper and the Virtual Terminal era and the Visual Display Editor.



TinyCLOS
; *********************************************************************= *
; Copyright (c) 1992 Xerox Corporation.=A0
; All Rights Reserved.=A0
;
; 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.=A0 Any distribution of this software or derivative works
; must comply with all applicable United States export control laws.<= br> ;
; 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<= br> ; 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<= br> ; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGES.
; *********************************************************************= *

--------------040701010300090304060906-- --------------030903020306090903020801 Content-Type: text/x-scheme; name="tiny-clos.scm" Content-Disposition: attachment; filename="tiny-clos.scm" Content-Transfer-Encoding: 7bit ; 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 --------------030903020306090903020801--