--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: class.scm,v 1.1 1997/06/04 06:08:13 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Classes
+
+(declare (usual-integrations))
+\f
+(define-structure (class (conc-name class/)
+ (constructor %make-class
+ (name direct-superclasses direct-slots))
+ (print-procedure
+ (standard-unparser-method 'CLASS
+ (lambda (class port)
+ (let ((name (class-name class)))
+ (if name
+ (begin
+ (write-char #\space port)
+ (write name port))))))))
+ (name #f read-only #t)
+ (direct-superclasses #f read-only #t)
+ (direct-slots #f read-only #t)
+ precedence-list
+ slots
+ dispatch-tag)
+
+(define (make-class name direct-superclasses direct-slots)
+ (let ((class
+ (%make-class name
+ (if (null? direct-superclasses)
+ (list <instance>)
+ direct-superclasses)
+ (map (lambda (slot)
+ (canonicalize-slot-argument slot 'MAKE-CLASS))
+ direct-slots))))
+ (set-class/precedence-list! class (compute-precedence-list class))
+ (set-class/slots! class (compute-slots class))
+ (set-class/dispatch-tag! class (make-dispatch-tag class))
+ (install-slot-accessor-methods class)
+ class))
+
+(define (make-trivial-subclass superclass . superclasses)
+ (make-class (class-name superclass) (cons superclass superclasses) '()))
+
+(define <object>
+ (let ((class (%make-class '<OBJECT> '() '())))
+ (set-class/precedence-list! class (list class))
+ (set-class/slots! class '())
+ (set-class/dispatch-tag! class (make-dispatch-tag class))
+ class))
+\f
+(define (class-name class)
+ (guarantee-class class 'CLASS-NAME)
+ (class/name class))
+
+(define (class-direct-superclasses class)
+ (guarantee-class class 'CLASS-DIRECT-SUPERCLASSES)
+ (class/direct-superclasses class))
+
+(define (class-direct-slot-names class)
+ (guarantee-class class 'CLASS-DIRECT-SLOTS)
+ (map car (class/direct-slots class)))
+
+(define (class-precedence-list class)
+ (guarantee-class class 'CLASS-PRECEDENCE-LIST)
+ (class/precedence-list class))
+
+(define (class-slots class)
+ (guarantee-class class 'CLASS-SLOTS)
+ (class/slots class))
+
+(define (class-slot class name error?)
+ (guarantee-class class 'CLASS-SLOT)
+ (or (list-search-positive (class/slots class)
+ (lambda (slot)
+ (eq? name (slot-name slot))))
+ (and error? (error:bad-range-argument name 'CLASS-SLOT))))
+
+(define (class->dispatch-tag class)
+ (guarantee-class class 'CLASS->DISPATCH-TAG)
+ (class/dispatch-tag class))
+
+(define (subclass? c1 c2)
+ ;; A union specializer can't be a subclass of anything, but a class
+ ;; can be a subclass of a union specializer.
+ (guarantee-class c1 'SUBCLASS?)
+ (if (union-specializer? c2)
+ (there-exists? (union-specializer-classes c2)
+ (lambda (c2)
+ (memq c2 (class/precedence-list c1))))
+ (begin
+ (guarantee-class c2 'SUBCLASS?)
+ (memq c2 (class/precedence-list c1)))))
+
+(define (guarantee-class class name)
+ (if (not (class? class))
+ (error:wrong-type-argument class "class" name)))
+\f
+(define (compute-precedence-list class)
+ (let ((elements (build-transitive-closure class/direct-superclasses class)))
+ (topological-sort
+ elements
+ (build-constraints class/direct-superclasses elements)
+ (lambda (partial-cpl elements)
+ (let loop ((partial-cpl (reverse partial-cpl)))
+ (if (null? partial-cpl)
+ (error:bad-range-argument class 'COMPUTE-PRECEDENCE-LIST))
+ (let ((ds-of-ce
+ (class/direct-superclasses (car partial-cpl))))
+ (let find-common ((elements elements))
+ (cond ((null? elements) (loop (cdr partial-cpl)))
+ ((memq (car elements) ds-of-ce) (car elements))
+ (else (find-common (cdr elements)))))))))))
+
+(define (compute-slots class)
+ (let loop
+ ((slots (append-map class/direct-slots (class/precedence-list class)))
+ (index 1)
+ (descriptors '()))
+ (if (null? slots)
+ (reverse! descriptors)
+ (let ((slot (car slots)))
+ (let ((name (car slot)))
+ (let inner ((slots (cdr slots)) (same '()) (diff '()))
+ (cond ((null? slots)
+ (loop (reverse! diff)
+ (+ index 1)
+ (cons (compute-slot-descriptor
+ class
+ (cons slot (reverse! same))
+ index)
+ descriptors)))
+ ((eq? name (caar slots))
+ (inner (cdr slots)
+ (cons (car slots) same)
+ diff))
+ (else
+ (inner (cdr slots)
+ same
+ (cons (car slots) diff))))))))))
+\f
+;;;; Topological Sort
+
+;;; Topologically sort a list of ELEMENTS. CONSTRAINTS is the partial
+;;; order, expressed as a list of pairs (X . Y) where X precedes Y.
+;;; TIE-BREAKER is a procedure that is called when it is necessary to
+;;; choose from multiple minimal elements; it is called with the
+;;; partial result and the set of minimal elements as its arguments.
+
+(define (topological-sort elements original-constraints tie-breaker)
+ (let ((result (cons '() '())))
+ (let ((add-to-result
+ (lambda (element)
+ (let ((tail (list element)))
+ (if (null? (car result))
+ (set-car! result tail)
+ (set-cdr! (cdr result) tail))
+ (set-cdr! result tail)))))
+ (let loop
+ ((elements (list-copy elements))
+ (constraints (list-copy original-constraints)))
+ (if (null? elements)
+ (car result)
+ (let ((minimal
+ (remove-if (lambda (element)
+ (let loop ((constraints constraints))
+ (and (not (null? constraints))
+ (or (eq? (cdar constraints) element)
+ (loop (cdr constraints))))))
+ elements)))
+ (if (null? minimal)
+ (error:bad-range-argument original-constraints
+ 'TOPOLOGICAL-SORT))
+ (let ((elements
+ (remove-if! (lambda (element)
+ (memq element minimal))
+ elements))
+ (constraints
+ (remove-if! (lambda (constraint)
+ (or (memq (car constraint) minimal)
+ (memq (cdr constraint) minimal)))
+ constraints)))
+ (let break-ties ((minimal minimal))
+ (if (null? (cdr minimal))
+ (let ((choice (car minimal)))
+ (add-to-result choice)
+ (loop elements constraints))
+ (let ((choice (tie-breaker (car result) minimal)))
+ (add-to-result choice)
+ (break-ties (remove-item! choice minimal))))))))))))
+
+(define (build-transitive-closure get-follow-ons element)
+ (let loop ((result '()) (pending (list element)))
+ (cond ((null? pending)
+ result)
+ ((memq (car pending) result)
+ (loop result (cdr pending)))
+ (else
+ (loop (cons (car pending) result)
+ (append (get-follow-ons (car pending)) (cdr pending)))))))
+
+(define (build-constraints get-follow-ons elements)
+ (let loop ((elements elements) (result '()))
+ (if (null? elements)
+ result
+ (loop (cdr elements)
+ (let loop
+ ((element (car elements))
+ (follow-ons (get-follow-ons (car elements))))
+ (if (null? follow-ons)
+ result
+ (cons (cons element (car follow-ons))
+ (loop (car follow-ons) (cdr follow-ons)))))))))
+\f
+(define (remove-if predicate items)
+ (let loop ((items items))
+ (if (pair? items)
+ (if (predicate (car items))
+ (loop (cdr items))
+ (cons (car items) (loop (cdr items))))
+ '())))
+
+(define (remove-if! predicate items)
+ (letrec ((trim-initial-segment
+ (lambda (items)
+ (if (pair? items)
+ (if (predicate (car items))
+ (trim-initial-segment (cdr items))
+ (begin
+ (locate-initial-segment items (cdr items))
+ items))
+ items)))
+ (locate-initial-segment
+ (lambda (last this)
+ (if (pair? this)
+ (if (predicate (car this))
+ (set-cdr! last (trim-initial-segment (cdr this)))
+ (locate-initial-segment this (cdr this)))
+ this))))
+ (trim-initial-segment items)))
+
+(define (remove-item! item items)
+ (cond ((null? items)
+ items)
+ ((eq? item (car items))
+ (cdr items))
+ (else
+ (let loop ((last items) (this (cdr items)))
+ (if (not (null? this))
+ (if (eq? item (car this))
+ (set-cdr! last (cdr this))
+ (loop this (cdr this)))))
+ items)))
+\f
+;;;; Built-in Classes
+
+(define <instance> (make-class '<INSTANCE> (list <object>) '()))
+
+(let-syntax
+ ((define-primitive-class
+ (macro (name . superclasses)
+ `(DEFINE ,name (MAKE-CLASS ',name (LIST ,@superclasses) '())))))
+
+(define-primitive-class <boolean> <object>)
+(define-primitive-class <char> <object>)
+(define-primitive-class <pair> <object>)
+(define-primitive-class <%record> <object>)
+(define-primitive-class <record> <%record>)
+(define-primitive-class <dispatch-tag> <%record>)
+(define-primitive-class <string> <object>)
+(define-primitive-class <symbol> <object>)
+(define-primitive-class <vector> <object>)
+
+(define-primitive-class <number>)
+(define-primitive-class <complex> <number>)
+(define-primitive-class <real> <complex>)
+(define-primitive-class <rational> <real>)
+(define-primitive-class <integer> <rational>)
+
+(define-primitive-class <exact> <number>)
+(define-primitive-class <exact-complex> <complex> <exact>)
+(define-primitive-class <exact-real> <real> <exact-complex>)
+(define-primitive-class <exact-rational> <rational> <exact-real>)
+(define-primitive-class <exact-integer> <integer> <exact-rational>)
+
+(define-primitive-class <inexact> <number>)
+(define-primitive-class <inexact-complex> <complex> <inexact>)
+(define-primitive-class <inexact-real> <real> <inexact-complex>)
+(define-primitive-class <inexact-rational> <rational> <inexact-real>)
+(define-primitive-class <inexact-integer> <integer> <inexact-rational>)
+
+(define-primitive-class <fixnum> <exact-integer>)
+(define-primitive-class <bignum> <exact-integer>)
+(define-primitive-class <ratnum> <exact-rational>)
+(define-primitive-class <flonum> <inexact-rational>)
+(define-primitive-class <flonum-vector> <flonum>)
+(define-primitive-class <recnum> <complex>)
+
+(define-primitive-class <procedure> <object>)
+(define-primitive-class <generic-procedure> <procedure>)
+(define-primitive-class <entity> <procedure>)
+
+)
+\f
+(define (object-class object)
+ (dispatch-tag->class (dispatch-tag object)))
+
+(define (record-type-class type)
+ (dispatch-tag->class (record-type-dispatch-tag type)))
+
+(define (record-class record)
+ (record-type-class (record-type-descriptor record)))
+
+(define (dispatch-tag->class tag)
+ (let ((contents (dispatch-tag-contents tag)))
+ (cond ((class? contents) contents)
+ ((hash-table/get built-in-class-table tag #f))
+ ((record-type? contents)
+ (let ((class (make-record-type-class contents)))
+ (hash-table/put! built-in-class-table tag class)
+ class))
+ (else <object>))))
+
+(define (make-record-type-class type)
+ (make-class (string->symbol (string-append "<" (record-type-name type) ">"))
+ (list <record>)
+ (record-type-field-names type)))
+
+(define built-in-class-table
+ (make-eq-hash-table))
+
+(let ((assign-type
+ (lambda (name class)
+ (hash-table/put! built-in-class-table
+ (or (built-in-dispatch-tag name)
+ (built-in-dispatch-tag
+ (microcode-type/code->name
+ (microcode-type/name->code name)))
+ (error "Unknown type name:" name))
+ class))))
+ (assign-type 'BOOLEAN <boolean>)
+ (assign-type 'CHARACTER <char>)
+ (assign-type 'PAIR <pair>)
+ (assign-type 'RECORD <%record>)
+ (assign-type 'DISPATCH-TAG <dispatch-tag>)
+ (assign-type 'STRING <string>)
+ (assign-type 'INTERNED-SYMBOL <symbol>)
+ (assign-type 'UNINTERNED-SYMBOL <symbol>)
+ (assign-type 'VECTOR <vector>)
+
+ (assign-type 'COMPILED-PROCEDURE <procedure>)
+ (assign-type 'EXTENDED-PROCEDURE <procedure>)
+ (assign-type 'PRIMITIVE <procedure>)
+ (assign-type 'PROCEDURE <procedure>)
+ (assign-type 'ENTITY <entity>)
+
+ (if (> microcode-id/version 11)
+ (begin
+ (assign-type 'POSITIVE-FIXNUM <fixnum>)
+ (assign-type 'NEGATIVE-FIXNUM <fixnum>))
+ (assign-type 'FIXNUM <fixnum>))
+ (assign-type 'BIGNUM <bignum>)
+ (assign-type 'RATNUM <ratnum>)
+ (assign-type 'FLONUM <flonum>)
+ (assign-type 'FLONUM-VECTOR <flonum-vector>)
+ (assign-type 'RECNUM <recnum>))
+
+(hash-table/put! built-in-class-table
+ standard-generic-procedure-tag
+ <generic-procedure>)
+
+(define <class> (object-class <object>))
+
+(define (instance-predicate class)
+ (guarantee-class class 'INSTANCE-PREDICATE)
+ (lambda (object) (instance-of? object class)))
+
+(define (instance-of? object class)
+ (and (subclass? (object-class object) class)
+ #t))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: compile.scm,v 1.1 1997/06/04 06:08:30 cph Exp $
+;;;
+;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+(load-option 'CREF)
+
+(define compile-file-override-usual-integrations '())
+(define compile-file-sf-only? #f)
+(define compile-file)
+(let ((scm-pathname (lambda (path) (pathname-new-type path "scm")))
+ (bin-pathname (lambda (path) (pathname-new-type path "bin")))
+ (ext-pathname (lambda (path) (pathname-new-type path "ext")))
+ (com-pathname (lambda (path) (pathname-new-type path "com"))))
+
+ (define (process-file input-file output-file dependencies processor)
+ (let ((reasons
+ (let ((output-time (file-modification-time output-file)))
+ (if (not output-time)
+ (list input-file)
+ (list-transform-positive (cons input-file dependencies)
+ (lambda (dependency)
+ (let ((dep-time (file-modification-time dependency)))
+ (if dep-time
+ (> dep-time output-time)
+ (begin
+ (warn "Missing dependency:"
+ (->namestring dependency))
+ #f)))))))))
+ (if (not (null? reasons))
+ (begin
+ (newline)
+ (write-string ";Generating ")
+ (write (->namestring output-file))
+ (write-string " because of:")
+ (for-each (lambda (reason)
+ (write-char #\space)
+ (write (->namestring reason)))
+ reasons)
+ (processor input-file output-file dependencies)))))
+
+ (set! compile-file
+ (named-lambda (compile-file file #!optional dependencies syntax-table)
+ (process-file (scm-pathname file)
+ (bin-pathname file)
+ (map ext-pathname
+ (if (default-object? dependencies)
+ '()
+ dependencies))
+ (lambda (input-file output-file dependencies)
+ (fluid-let ((sf/default-syntax-table
+ (if (default-object? syntax-table)
+ #f
+ syntax-table))
+ (sf/default-declarations
+ `((USUAL-INTEGRATIONS
+ ,@compile-file-override-usual-integrations)
+ ,@(if (null? dependencies)
+ '()
+ `((INTEGRATE-EXTERNAL ,@dependencies))))))
+ (sf input-file output-file))))
+ (if (not compile-file-sf-only?)
+ (process-file (bin-pathname file)
+ (com-pathname file)
+ '()
+ (lambda (input-file output-file dependencies)
+ dependencies
+ (fluid-let ((compiler:coalescing-constant-warnings? #f))
+ (compile-bin-file input-file output-file))))))))
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (compile-file "class")
+ (compile-file "instance" '() syntax-table/system-internal)
+ (compile-file "macros")
+ (compile-file "method")
+ (compile-file "printer")
+ (compile-file "slot")
+ (cref/generate-constructors "sos")
+ (sf "sos.con")
+ (sf "sos.ldr")))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: instance.scm,v 1.1 1997/06/04 06:08:35 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Instances
+
+(declare (usual-integrations))
+\f
+;;;; Instance Constructor
+
+;;; First define macros to be used below, because the syntaxer
+;;; requires them to appear before their first reference.
+
+(define-macro (constructor-case nx low high fixed default)
+ `(CASE ,nx
+ ,@(let loop ((i low))
+ (if (= i high)
+ '()
+ `(((,i) (,fixed ,i))
+ ,@(loop (+ i 1)))))
+ (ELSE ,default)))
+
+(define-macro (fixed-initialization n)
+ (let ((indexes
+ (make-initialized-list n
+ (lambda (index)
+ (intern (string-append "n" (number->string index))))))
+ (initializers
+ (make-initialized-list n
+ (lambda (index)
+ (intern (string-append "i" (number->string index)))))))
+ `(LET (,@(make-initialized-list n
+ (lambda (index)
+ `(,(list-ref indexes index)
+ (LIST-REF INDEXES ,index))))
+ ,@(make-initialized-list n
+ (lambda (index)
+ `(,(list-ref initializers index)
+ (LIST-REF INITIALIZERS ,index)))))
+ (LAMBDA (INSTANCE)
+ ,@(map (lambda (index initializer)
+ `(%RECORD-SET! INSTANCE ,index (,initializer)))
+ indexes
+ initializers)))))
+
+(define-macro (fixed-arity-constructor n)
+ (let ((indexes
+ (make-initialized-list n
+ (lambda (index)
+ (intern (string-append "i" (number->string index))))))
+ (values
+ (make-initialized-list n
+ (lambda (index)
+ (intern (string-append "v" (number->string index)))))))
+ (let ((make-lambda
+ (lambda (initialization)
+ `(LAMBDA ,values
+ (LET ((INSTANCE
+ (OBJECT-NEW-TYPE
+ (UCODE-TYPE RECORD)
+ (MAKE-VECTOR INSTANCE-LENGTH
+ RECORD-SLOT-UNINITIALIZED))))
+ (%RECORD-SET! INSTANCE 0 INSTANCE-TAG)
+ ,@initialization
+ ,@(map (lambda (index value)
+ `(%RECORD-SET! INSTANCE ,index ,value))
+ indexes
+ values)
+ INSTANCE)))))
+ `(LET ,(make-initialized-list n
+ (lambda (index)
+ `(,(list-ref indexes index)
+ (LIST-REF INDEXES ,index))))
+ (IF INITIALIZATION
+ ,(make-lambda `((INITIALIZATION INSTANCE)))
+ ,(make-lambda '()))))))
+\f
+(define (instance-constructor class slot-names)
+ (let ((slots (map (lambda (name) (class-slot class name #t)) slot-names))
+ (instance-length (fix:+ (length (class-slots class)) 1))
+ (instance-tag (class->dispatch-tag class)))
+ (let ((n-values (length slots))
+ (initialization
+ (let ((slots
+ (list-transform-positive (class-slots class)
+ (lambda (slot)
+ (and (slot-initializer slot)
+ (not (memq slot slots)))))))
+ (and (not (null? slots))
+ (let ((indexes (map slot-index slots))
+ (initializers (map slot-initializer slots)))
+ (constructor-case (length slots) 1 4 fixed-initialization
+ (lambda (instance)
+ (do ((initializers initializers (cdr initializers))
+ (indexes indexes (cdr indexes)))
+ ((null? initializers) unspecific)
+ (%record-set! instance
+ (car indexes)
+ ((car initializers)))))))))))
+ (let ((indexes (map slot-index slots)))
+ (constructor-case n-values 0 8 fixed-arity-constructor
+ (letrec
+ ((procedure
+ (lambda values
+ (if (not (fix:= n-values (length values)))
+ (error:wrong-number-of-arguments procedure
+ n-values values))
+ (let ((instance
+ (object-new-type
+ (ucode-type record)
+ (make-vector instance-length
+ record-slot-uninitialized))))
+ (%record-set! instance 0 instance-tag)
+ (if initialization (initialization instance))
+ (do ((indexes indexes (cdr indexes))
+ (values values (cdr values)))
+ ((null? indexes))
+ (%record-set! instance (car indexes) (car values)))
+ instance))))
+ procedure))))))
+
+(define (instance? object)
+ (and (tagged-vector? object)
+ (class? (dispatch-tag-contents (tagged-vector-tag object)))))
+
+(define (instance-class instance)
+ (dispatch-tag-contents (tagged-vector-tag instance)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: load.scm,v 1.1 1997/06/04 06:08:40 cph Exp $
+;;;
+;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+(load-option 'HASH-TABLE)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (package/system-loader "sos" '() 'QUERY)))
+(let ((install
+ (let ((environment (package/environment (find-package '(SOS MACROS)))))
+ (lambda (mname tname)
+ (syntax-table/define system-global-syntax-table
+ mname
+ (lexical-reference environment tname))))))
+ (install 'DEFINE-CLASS 'TRANSFORM:DEFINE-CLASS)
+ (install 'DEFINE-GENERIC 'TRANSFORM:DEFINE-GENERIC)
+ (install 'DEFINE-METHOD 'TRANSFORM:DEFINE-METHOD)
+ (install 'DEFINE-COMPUTED-METHOD 'TRANSFORM:DEFINE-COMPUTED-METHOD)
+ (install 'DEFINE-COMPUTED-EMP 'TRANSFORM:DEFINE-COMPUTED-EMP)
+ ;;(install 'METHOD 'TRANSFORM:METHOD)
+ )
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: macros.scm,v 1.1 1997/06/04 06:08:44 cph Exp $
+;;;
+;;; Copyright (c) 1993-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Macros
+
+(declare (usual-integrations))
+\f
+(define (transform:define-class name superclasses . slot-arguments)
+ (let ((lose
+ (lambda (s a)
+ (serror 'DEFINE-CLASS (string-append "Malformed " s ":") a))))
+ (if (not (symbol? name))
+ (lose "class name" name))
+ (if (not (list? superclasses))
+ (lose "superclasses" superclasses))
+ (let ((definitions
+ (extract-generic-definitions! slot-arguments name lose)))
+ `(BEGIN
+ ,@definitions
+ (DEFINE ,name
+ (MAKE-CLASS ',name (LIST ,@superclasses)
+ (LIST
+ ,@(map
+ (lambda (arg)
+ (cond ((symbol? arg)
+ `',arg)
+ ((and (pair? arg)
+ (symbol? (car arg))
+ (list? (cdr arg)))
+ `(LIST ',(car arg)
+ ,@(let loop ((plist (cdr arg)))
+ (cond ((null? plist)
+ '())
+ ((and (symbol? (car plist))
+ (pair? (cdr plist)))
+ (cons* `',(car plist)
+ (cadr plist)
+ (loop (cddr plist))))
+ (else
+ (lose "slot argument" arg))))))
+ (else
+ (lose "slot argument" arg))))
+ slot-arguments))))))))
+\f
+(define (extract-generic-definitions! slot-arguments name lose)
+ (let ((definitions '()))
+ (for-each
+ (lambda (arg)
+ (if (and (pair? arg)
+ (symbol? (car arg))
+ (list? (cdr arg)))
+ (let loop ((plist (cdr arg)) (prev arg))
+ (if (and (pair? plist) (pair? (cdr plist)))
+ (if (eq? 'DEFINE (car plist))
+ (begin
+ (let ((keyword?
+ (lambda (element)
+ (or (eq? 'ACCESSOR element)
+ (eq? 'MODIFIER element)
+ (eq? 'INITPRED element)))))
+ (if (not (or (eq? 'STANDARD (cadr plist))
+ (keyword? (cadr plist))
+ (and (list? (cadr plist))
+ (for-all? (cadr plist) keyword?))))
+ (lose "DEFINE property" arg)))
+ (set-cdr! prev (cddr plist))
+ (set! definitions
+ (append! (translate-define-arg (cadr plist)
+ name
+ arg)
+ definitions)))
+ (loop (cddr plist) (cdr plist)))))))
+ slot-arguments)
+ definitions))
+
+(define (translate-define-arg arg name slot-argument)
+ (let ((translate
+ (lambda (keyword standard? arity generate)
+ (if (or (and standard? (eq? 'STANDARD arg))
+ (eq? keyword arg)
+ (and (pair? arg) (memq keyword arg)))
+ `((DEFINE
+ ,(or (plist-lookup keyword (cdr slot-argument) #f)
+ (let ((name
+ (generate
+ (symbol-append (strip-angle-brackets name)
+ '-
+ (car slot-argument)))))
+ (set-cdr! slot-argument
+ (cons* keyword name (cdr slot-argument)))
+ name))
+ (MAKE-GENERIC-PROCEDURE ,arity)))
+ '()))))
+ (append (translate 'ACCESSOR #t 1
+ (lambda (root) root))
+ (translate 'MODIFIER #t 2
+ (lambda (root) (symbol-append 'set- root '!)))
+ (translate 'INITPRED #f 1
+ (lambda (root) (symbol-append root '-initialized?))))))
+
+(define (plist-lookup key plist default)
+ (let loop ((plist plist))
+ (if (and (pair? plist) (pair? (cdr plist)))
+ (if (eq? key (car plist))
+ (cadr plist)
+ (loop (cddr plist)))
+ default)))
+
+(define (strip-angle-brackets symbol)
+ (let ((s (symbol->string symbol)))
+ (if (and (fix:>= (string-length s) 2)
+ (char=? #\< (string-ref s 0))
+ (char=? #\> (string-ref s (fix:- (string-length s) 1))))
+ (string->symbol (substring s 1 (fix:- (string-length s) 1)))
+ symbol)))
+\f
+(define (transform:define-generic name lambda-list)
+ (let ((mname 'DEFINE-GENERIC))
+ (if (not (symbol? name))
+ (serror mname "Malformed generic procedure name:" name))
+ (call-with-values (lambda () (parse-lambda-list lambda-list #f mname))
+ (lambda (required optional rest)
+ `(DEFINE ,name
+ (MAKE-GENERIC-PROCEDURE
+ ',(let ((low (length required)))
+ (cond (rest (cons low #f))
+ ((null? optional) low)
+ (else (cons low (+ low (length optional))))))
+ ',name))))))
+
+(define (transform:define-method name lambda-list . body)
+ (%transform:define-method name lambda-list body 'DEFINE-METHOD
+ generate-method-definition))
+
+(define (transform:define-computed-method name lambda-list . body)
+ (%transform:define-method name lambda-list body 'DEFINE-COMPUTED-METHOD
+ generate-computed-method-definition))
+
+(define (%transform:define-method name lambda-list body mname generator)
+ (if (not (symbol? name))
+ (serror mname "Malformed generic procedure name:" name))
+ (call-with-values (lambda () (parse-lambda-list lambda-list #t mname))
+ (lambda (required optional rest)
+ (call-with-values (lambda () (extract-required-specializers required))
+ (lambda (required specializers)
+ (generator name required specializers optional rest body))))))
+
+(define (generate-method-definition name required specializers optional rest
+ body)
+ `(ADD-METHOD ,name
+ ,(make-method-sexp name required optional rest specializers body)))
+
+(define (generate-computed-method-definition name required specializers
+ optional rest body)
+ `(ADD-METHOD ,name
+ (MAKE-COMPUTED-METHOD (LIST ,@specializers)
+ ,(make-named-lambda name required optional rest body))))
+
+(define (transform:define-computed-emp name key lambda-list . body)
+ (let ((mname 'DEFINE-COMPUTED-EMP))
+ (if (not (symbol? name))
+ (serror mname "Malformed generic procedure name:" name))
+ (call-with-values (lambda () (parse-lambda-list lambda-list #t mname))
+ (lambda (required optional rest)
+ (call-with-values (lambda () (extract-required-specializers required))
+ (lambda (required specializers)
+ `(ADD-METHOD ,name
+ (MAKE-COMPUTED-EMP ,key (LIST ,@specializers)
+ ,(make-named-lambda name required optional rest body)))))))))
+
+(define (transform:method lambda-list . body)
+ (call-with-values (lambda () (parse-lambda-list lambda-list #t 'METHOD))
+ (lambda (required optional rest)
+ (call-with-values (lambda () (extract-required-specializers required))
+ (lambda (required specializers)
+ (make-method-sexp #f required optional rest specializers body))))))
+\f
+(define (extract-required-specializers required)
+ (let loop ((required required) (names '()) (specializers '()))
+ (cond ((null? required)
+ (values (reverse! names)
+ (reverse! (let loop ((specializers specializers))
+ (if (and (not (null? specializers))
+ (eq? '<OBJECT> (car specializers))
+ (not (null? (cdr specializers))))
+ (loop (cdr specializers))
+ specializers)))))
+ ((pair? (car required))
+ (loop (cdr required)
+ (cons (caar required) names)
+ (cons (cadar required) specializers)))
+ (else
+ (loop (cdr required)
+ (cons (car required) names)
+ (cons '<OBJECT> specializers))))))
+
+(define (make-method-sexp name required optional rest specializers body)
+ (let ((normal
+ (lambda ()
+ (call-with-values (lambda () (call-next-method-used? body))
+ (lambda (body used?)
+ `(,(if used? 'MAKE-CHAINED-METHOD 'MAKE-METHOD)
+ (LIST ,@specializers)
+ ,(make-named-lambda name
+ (if used?
+ (cons 'CALL-NEXT-METHOD required)
+ required)
+ optional
+ rest
+ body)))))))
+ (if (and (null? optional)
+ (not rest)
+ (not (eq? '<OBJECT> (car specializers))))
+ (case (length required)
+ ((1)
+ (cond ((match `((SLOT-VALUE ,(car required) ',symbol?)) body)
+ `(SLOT-ACCESSOR-METHOD ,(car specializers) ,(caddar body)))
+ ((match `((SLOT-INITIALIZED? ,(car required) ',symbol?)) body)
+ `(SLOT-INITPRED-METHOD ,(car specializers) ,(caddar body)))
+ (else (normal))))
+ ((2)
+ (if (and (null? (cdr specializers))
+ (match `((SET-SLOT-VALUE! ,(car required)
+ ',symbol?
+ ,(cadr required)))
+ body))
+ `(SLOT-MODIFIER-METHOD ,(car specializers) ,(caddar body))
+ (normal)))
+ (else (normal)))
+ (normal))))
+
+(define (match pattern instance)
+ (cond ((procedure? pattern)
+ (pattern instance))
+ ((pair? pattern)
+ (and (pair? instance)
+ (match (car pattern) (car instance))
+ (match (cdr pattern) (cdr instance))))
+ (else
+ (eqv? pattern instance))))
+\f
+(define (call-next-method-used? body)
+ (if (null? body)
+ (values body #f)
+ (let ((body
+ (let loop ((body body))
+ (cond ((or (not (symbol? (car body)))
+ (null? (cdr body)))
+ body)
+ ((eq? (car body) 'CALL-NEXT-METHOD)
+ (loop (cdr body)))
+ (else
+ (cons (car body) (loop (cdr body))))))))
+ (values body
+ (free-variable? 'CALL-NEXT-METHOD
+ (syntax* body))))))
+
+(define free-variable?
+ (letrec
+ ((do-expr
+ (lambda (name expr)
+ ((scode-walk scode-walker expr) name expr)))
+ (do-exprs
+ (lambda (name exprs)
+ (if (null? exprs)
+ '()
+ (or (do-expr name (car exprs))
+ (do-exprs name (cdr exprs))))))
+ (scode-walker
+ (make-scode-walker
+ (lambda (name expr) name expr #f)
+ `((ACCESS
+ ,(lambda (name expr)
+ name
+ (if (access-environment expr)
+ (illegal expr)
+ #f)))
+ (ASSIGNMENT
+ ,(lambda (name expr)
+ (or (eq? name (assignment-name expr))
+ (do-expr name (assignment-value expr)))))
+ (COMBINATION
+ ,(lambda (name expr)
+ (or (do-expr name (combination-operator expr))
+ (do-exprs name (combination-operands expr)))))
+ (COMMENT
+ ,(lambda (name expr)
+ (do-expr name (comment-expression expr))))
+ (CONDITIONAL
+ ,(lambda (name expr)
+ (do-exprs name (conditional-components expr list))))
+ (DELAY
+ ,(lambda (name expr)
+ (do-expr name (delay-expression expr))))
+ (DISJUNCTION
+ ,(lambda (name expr)
+ (do-exprs name (disjunction-components expr list))))
+ (DEFINITION ,(lambda (name expr) name (illegal expr)))
+ (IN-PACKAGE ,(lambda (name expr) name (illegal expr)))
+ (LAMBDA
+ ,(lambda (name expr)
+ (lambda-components expr
+ (lambda (lname required optional rest auxiliary decls body)
+ lname decls
+ (and (not (or (memq name required)
+ (memq name optional)
+ (eq? name rest)
+ (memq name auxiliary)))
+ (do-expr name body))))))
+ (SEQUENCE
+ ,(lambda (name expr)
+ (do-exprs name (sequence-actions expr))))
+ (VARIABLE
+ ,(lambda (name expr)
+ (eq? name (variable-name expr)))))))
+ (illegal (lambda (expr) (error "Illegal expression:" expr))))
+ do-expr))
+\f
+(define (parse-lambda-list lambda-list allow-specializers? specform)
+ specform
+ (let ((required '())
+ (optional '())
+ (rest #f))
+ (letrec
+ ((parse-required
+ (lambda (lambda-list)
+ (cond ((null? lambda-list)
+ (finish))
+ ((pair? lambda-list)
+ (cond ((or (valid-name? (car lambda-list))
+ (and allow-specializers?
+ (pair? (car lambda-list))
+ (valid-name? (caar lambda-list))
+ (pair? (cdar lambda-list))
+ (null? (cddar lambda-list))))
+ (set! required (cons (car lambda-list) required))
+ (parse-required (cdr lambda-list)))
+ ((eq? #!optional (car lambda-list))
+ (parse-optional (cdr lambda-list)))
+ ((eq? #!rest (car lambda-list))
+ (parse-rest (cdr lambda-list)))
+ (else
+ (illegal-element lambda-list))))
+ ((symbol? lambda-list)
+ (set! rest lambda-list)
+ (finish))
+ (else
+ (illegal-tail lambda-list)))))
+ (parse-optional
+ (lambda (lambda-list)
+ (cond ((null? lambda-list)
+ (finish))
+ ((pair? lambda-list)
+ (cond ((valid-name? (car lambda-list))
+ (set! optional (cons (car lambda-list) optional))
+ (parse-optional (cdr lambda-list)))
+ ((eq? #!optional (car lambda-list))
+ (error "#!optional may not recur:" lambda-list))
+ ((eq? #!rest (car lambda-list))
+ (parse-rest (cdr lambda-list)))
+ (else
+ (illegal-element lambda-list))))
+ ((symbol? lambda-list)
+ (set! rest lambda-list)
+ (finish))
+ (else
+ (illegal-tail lambda-list)))))
+ (parse-rest
+ (lambda (lambda-list)
+ (if (and (pair? lambda-list)
+ (null? (cdr lambda-list)))
+ (if (valid-name? (car lambda-list))
+ (begin
+ (set! rest (car lambda-list))
+ (finish))
+ (illegal-element lambda-list))
+ (illegal-tail lambda-list))))
+ (valid-name?
+ (lambda (element)
+ (and (symbol? element)
+ (not (eq? #!optional element))
+ (not (eq? #!rest element)))))
+ (finish
+ (lambda ()
+ (values (reverse! required)
+ (reverse! optional)
+ rest)))
+ (illegal-tail
+ (lambda (lambda-list)
+ (error "Illegal parameter list tail:" lambda-list)))
+ (illegal-element
+ (lambda (lambda-list)
+ (error "Illegal parameter list element:" (car lambda-list)))))
+ (parse-required lambda-list))))
+\f
+(define (make-named-lambda name required optional rest body)
+ (let ((bvl
+ (append required
+ (if (null? optional)
+ '()
+ `(#!OPTIONAL ,@optional))
+ (or rest '()))))
+ (if name
+ `(NAMED-LAMBDA (,name ,@bvl) ,@body)
+ `(LAMBDA ,bvl ,@body))))
+
+(define (serror procedure message . objects)
+ procedure
+ (apply error message objects))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: method.scm,v 1.1 1997/06/04 06:08:49 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Methods and Effective Method Procedures
+
+(declare (usual-integrations))
+\f
+;;;; Adding/Removing Methods
+
+(define (add-method generic method)
+ (guarantee-valid-method method generic 'ADD-METHOD)
+ (for-each
+ (lambda (method)
+ (modify-methods generic
+ (lambda (methods)
+ (let ((tail
+ (if (computed-emp? method)
+ (and (computed-emp-key method)
+ (computed-emp-member method methods))
+ (method-member method methods))))
+ (if tail
+ (begin
+ (warn "Replacing method"
+ (car tail)
+ (error-irritant/noise " with")
+ method
+ (error-irritant/noise " in procedure")
+ generic
+ (error-irritant/noise "."))
+ (set-car! tail method)
+ methods)
+ (cons method methods))))))
+ (if (computed-emp? method)
+ (list method)
+ (enumerate-union-specializers method)))
+ (if (computed-emp? method)
+ (purge-generic-procedure-cache generic)
+ (purge-method-entries generic method)))
+
+(define method-member
+ (member-procedure
+ (lambda (x y)
+ (and (not (computed-emp? x))
+ (not (computed-emp? y))
+ (specializers=? (method-specializers x) (method-specializers y))))))
+
+(define computed-emp-member
+ (member-procedure
+ (lambda (x y)
+ (and (computed-emp? x)
+ (computed-emp? y)
+ (equal? (computed-emp-key x) (computed-emp-key y))))))
+
+(define (delete-method generic method)
+ (guarantee-valid-method method generic 'DELETE-METHOD)
+ (modify-methods generic (lambda (methods) (delq! method methods)))
+ (purge-method-entries generic method))
+
+(define (guarantee-valid-method method generic name)
+ (guarantee-method method name)
+ (guarantee-generic-procedure generic name)
+ ;; Assumes that method instantiation has guaranteed that there is at
+ ;; least one specializer. This is handled by GUARANTEE-SPECIALIZERS.
+ (if (< (arity-min (generic-procedure-arity generic))
+ (length (method-specializers method)))
+ (error:bad-range-argument method name)))
+
+(define (guarantee-method method name)
+ (if (not (method? method))
+ (error:wrong-type-argument method "method" name)))
+
+(define (purge-method-entries generic method)
+ (purge-generic-procedure-cache generic
+ (lambda (generic tags)
+ generic
+ (method-applicable? method (map dispatch-tag->class tags)))))
+
+(define (add-methods generic methods)
+ (for-each (lambda (method) (add-method generic method)) methods))
+\f
+;;;; Method Combinators
+
+(define (method-combinator-record generic intern?)
+ (let ((combinator
+ (or (list-search-positive (generic-procedure-generator-list generic)
+ method-combinator?)
+ (and intern?
+ (let ((combinator (make-method-combinator)))
+ (add-generic-procedure-generator generic combinator)
+ combinator)))))
+ (and combinator
+ (apply-hook-extra combinator))))
+
+(define (method-combinator? object)
+ (and (apply-hook? object)
+ (combinator-record? (apply-hook-extra object))))
+
+(define (make-method-combinator)
+ (make-apply-hook (lambda (generic tags)
+ (compute-effective-method-procedure
+ generic
+ (map dispatch-tag->class tags)))
+ (make-combinator-record)))
+
+(define-structure (combinator-record (constructor make-combinator-record ()))
+ (methods '()))
+
+(define (modify-methods generic modifier)
+ (let ((record (method-combinator-record generic #t)))
+ (set-combinator-record-methods!
+ record
+ (modifier (combinator-record-methods record)))))
+
+(define (generic-procedure-methods generic)
+ (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-METHODS)
+ (let ((record (method-combinator-record generic #f)))
+ (if record
+ (list-copy (combinator-record-methods record))
+ '())))
+\f
+;;;; Effective Method Procedures
+
+(define (compute-method generic classes)
+ (let ((emp (compute-effective-method-procedure generic classes)))
+ (and emp
+ (make-method classes emp))))
+
+(define (compute-effective-method-procedure generic classes)
+ (or (try-emp-short-circuits generic classes)
+ (let ((methods (compute-methods generic classes)))
+ (or (try-computed-emps generic classes methods)
+ (and (not (null? methods))
+ (let loop ((methods methods))
+ (if (chained-method? (car methods))
+ ((method-procedure (car methods))
+ (if (null? (cdr methods))
+ (lambda args
+ (error:no-applicable-methods generic args))
+ (loop (cdr methods))))
+ (method-procedure (car methods)))))))))
+
+(define (try-computed-emps generic classes methods)
+ (let loop
+ ((generators
+ (sort-methods (list-transform-positive
+ (append-map enumerate-union-specializers
+ (list-transform-positive
+ (generic-procedure-methods generic)
+ computed-emp?))
+ (lambda (method)
+ (method-applicable? method classes)))
+ classes)))
+ (and (not (null? generators))
+ (let ((result (apply (method-procedure (car generators)) classes)))
+ (cond ((not result)
+ (loop (cdr generators)))
+ ((or (there-exists? (cdr generators)
+ (lambda (generator)
+ (and (specializers=?
+ (method-specializers generator)
+ (method-specializers (car generators)))
+ (apply (method-procedure generator) classes))))
+ (there-exists? methods
+ (lambda (method)
+ (specializers=? (method-specializers method)
+ classes))))
+ (lambda args
+ (error:extra-applicable-methods generic args)))
+ (else result))))))
+\f
+(define (compute-methods generic classes)
+ (sort-methods (compute-methods-1 generic classes) classes))
+
+(define (compute-methods-1 generic classes)
+ (let ((methods
+ (list-transform-positive (generic-procedure-methods generic)
+ (lambda (method)
+ (and (not (computed-emp? method))
+ (method-applicable? method classes))))))
+ (let ((results (list-transform-negative methods computed-method?)))
+ (for-each
+ (lambda (method)
+ (let ((result (apply (method-procedure method) classes)))
+ (if result
+ (begin
+ (set! results
+ (cons (make-method (method-specializers method) result)
+ results))
+ unspecific))))
+ (list-transform-positive methods computed-method?))
+ results)))
+
+(define (method-applicable? method classes)
+ (guarantee-method method 'METHOD-APPLICABLE?)
+ (subclasses? classes (method-specializers method)))
+
+(define (subclasses? classes specializers)
+ (let loop ((classes classes) (specializers specializers))
+ (or (null? specializers)
+ (and (subclass? (car classes) (car specializers))
+ (loop (cdr classes) (cdr specializers))))))
+
+(define (sort-methods methods classes)
+ (sort methods
+ (lambda (m1 m2)
+ (let loop
+ ((s1 (method-specializers m1))
+ (s2 (method-specializers m2))
+ (classes classes))
+ (and (not (null? s1))
+ (or (null? s2)
+ (if (eq? (car s1) (car s2))
+ (loop (cdr s1) (cdr s2) (cdr classes))
+ (memq (car s2)
+ (cdr (memq (car s1)
+ (class-precedence-list
+ (car classes))))))))))))
+\f
+;;;; Method Specializers
+
+(define (specializers? object)
+ (and (list? object)
+ (not (null? object))
+ (for-all? object specializer?)))
+
+(define (specializer? object)
+ (or (class? object)
+ (record-type? object)
+ (union-specializer? object)))
+
+(define (guarantee-specializers specializers non-null? name)
+ (if (not (specializers? specializers))
+ (error:wrong-type-argument specializers "list of method specializers"
+ name))
+ (if (and non-null? (null? specializers))
+ (error:bad-range-argument specializers name))
+ (map (lambda (specializer)
+ (if (record-type? specializer)
+ (record-type-class specializer)
+ specializer))
+ specializers))
+
+(define (specializers=? s1 s2)
+ (cond ((null? s1)
+ (let loop ((s2 s2))
+ (or (null? s2)
+ (and (eq? <object> (car s2))
+ (loop (cdr s2))))))
+ ((null? s2)
+ (let loop ((s1 s1))
+ (and (eq? <object> (car s1))
+ (or (null? (cdr s1))
+ (loop (cdr s1))))))
+ (else
+ (and (specializer=? (car s1) (car s2))
+ (specializers=? (cdr s1) (cdr s2))))))
+
+(define (specializer=? s1 s2)
+ (or (eq? s1 s2)
+ (and (union-specializer? s1)
+ (union-specializer? s2)
+ (union-specializer=? s1 s2))))
+\f
+(define union-spec-rtd (make-record-type 'UNION-SPECIALIZER '(CLASSES)))
+(define make-union-specializer (record-constructor union-spec-rtd))
+(define union-specializer? (record-predicate union-spec-rtd))
+(define union-specializer-classes (record-accessor union-spec-rtd 'CLASSES))
+
+(define (union-specializer . specializers)
+ (make-union-specializer
+ (append-map (lambda (specializer)
+ (if (union-specializer? specializer)
+ (union-specializer-classes specializer)
+ (list specializer)))
+ (guarantee-specializers specializers #f 'UNION-SPECIALIZER))))
+
+(define (union-specializer=? s1 s2)
+ (eq-set=? (union-specializer-classes s1) (union-specializer-classes s2)))
+
+(define (eq-set=? x y)
+ (and (for-all? x (lambda (x) (memq x y)))
+ (for-all? y (lambda (y) (memq y x)))))
+
+(define (enumerate-union-specializers method)
+ (let ((specializers (method-specializers method)))
+ (if (let loop ((specializers specializers))
+ (and (not (null? specializers))
+ (or (union-specializer? (car specializers))
+ (loop (cdr specializers)))))
+ (map (lambda (specializers)
+ (new-method-specializers method specializers))
+ (let loop ((specializers specializers))
+ (let ((classes
+ (let ((specializer (car specializers)))
+ (if (union-specializer? specializer)
+ (union-specializer-classes specializer)
+ (list specializer)))))
+ (if (null? (cdr specializers))
+ (map (lambda (class) (list class)) classes)
+ (let ((tails (loop (cdr specializers))))
+ (append-map (lambda (class)
+ (map (lambda (tail)
+ (cons class tail))
+ tails))
+ classes))))))
+ (list method))))
+
+(define (new-method-specializers method specializers)
+ (cond ((computed-method? method)
+ (make-computed-method specializers (method-procedure method)))
+ ((computed-emp? method)
+ (make-computed-emp (computed-emp-key method)
+ specializers
+ (method-procedure method)))
+ ((chained-method? method)
+ (make-chained-method specializers (method-procedure method)))
+ (else
+ (make-method specializers (method-procedure method)))))
+\f
+;;;; Method Types
+
+(define <method>
+ (make-class '<METHOD> '() '(SPECIALIZERS PROCEDURE)))
+
+(define make-method
+ (let ((%make (instance-constructor <method> '(SPECIALIZERS PROCEDURE))))
+ (lambda (specializers procedure)
+ (%make (guarantee-specializers specializers #t 'MAKE-METHOD)
+ procedure))))
+
+(define method?
+ (instance-predicate <method>))
+
+(define method-specializers
+ (make-generic-procedure 1 'METHOD-SPECIALIZERS))
+
+(define method-procedure
+ (make-generic-procedure 1 'METHOD-PROCEDURE))
+
+
+(define <chained-method>
+ (make-class '<CHAINED-METHOD> (list <method>) '()))
+
+(define make-chained-method
+ (let ((%make
+ (instance-constructor <chained-method> '(SPECIALIZERS PROCEDURE))))
+ (lambda (specializers procedure)
+ (%make (guarantee-specializers specializers #t 'MAKE-CHAINED-METHOD)
+ procedure))))
+
+(define chained-method?
+ (instance-predicate <chained-method>))
+
+
+(define <computed-method>
+ (make-class '<COMPUTED-METHOD> (list <method>) '()))
+
+(define make-computed-method
+ (let ((%make
+ (instance-constructor <computed-method> '(SPECIALIZERS PROCEDURE))))
+ (lambda (specializers procedure)
+ (%make (guarantee-specializers specializers #t 'MAKE-COMPUTED-METHOD)
+ procedure))))
+
+(define computed-method?
+ (instance-predicate <computed-method>))
+
+
+(define <computed-emp>
+ (make-class '<COMPUTED-EMP> (list <method>) '(KEY)))
+
+(define make-computed-emp
+ (let ((%make
+ (instance-constructor <computed-emp> '(KEY SPECIALIZERS PROCEDURE))))
+ (lambda (key specializers procedure)
+ (%make key
+ (guarantee-specializers specializers #t 'MAKE-COMPUTED-EMP)
+ procedure))))
+
+(define computed-emp?
+ (instance-predicate <computed-emp>))
+
+(define computed-emp-key
+ (make-generic-procedure 1 'COMPUTED-EMP-KEY))
+\f
+;;; This short-circuits the computation for method accessors. These
+;;; would otherwise need to be called in order to compute the result
+;;; for themselves, which would cause an infinite loop. This is done
+;;; as a three-stage process: (1) define the short-circuit hook, (2)
+;;; create method combinators for each of the accessors, to cause the
+;;; hook to be called, and (3) define the ordinary accessor methods,
+;;; which are used when the built-in method classes are subclassed.
+
+(define (try-emp-short-circuits generic classes)
+ (let ((entry (assq generic emp-short-circuits)))
+ (and entry
+ (memq (car classes) (cadr entry))
+ ((caddr entry) generic (map class->dispatch-tag classes)))))
+
+(define emp-short-circuits
+ (let ((get-specializers (%record-accessor-generator 'SPECIALIZERS))
+ (get-procedure (%record-accessor-generator 'PROCEDURE)))
+ (list (list method-specializers
+ (list <method> <chained-method> <computed-method>)
+ get-specializers)
+ (list method-procedure
+ (list <method> <chained-method> <computed-method>)
+ get-procedure)
+ (list computed-emp-key
+ (list <computed-emp>)
+ (%record-accessor-generator 'KEY)))))
+
+(method-combinator-record method-specializers #t)
+(method-combinator-record method-procedure #t)
+(method-combinator-record computed-emp-key #t)
+
+(add-method method-specializers
+ (slot-accessor-method <method> 'SPECIALIZERS))
+
+(add-method method-procedure
+ (slot-accessor-method <method> 'PROCEDURE))
+
+(add-method computed-emp-key
+ (slot-accessor-method <computed-emp> 'KEY))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: microbench.scm,v 1.1 1997/06/04 06:08:57 cph Exp $
+;;;
+;;; Copyright (c) 1993-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Micro-benchmarks for SOS
+
+(declare (usual-integrations))
+\f
+(define (f1 x)
+ x)
+
+(define (f2 x y)
+ y
+ x)
+
+(define (rf . x)
+ x)
+
+(define (get-f5)
+ (lambda (x)
+ x))
+
+(define (get-f6 y)
+ (lambda (x)
+ x
+ y))
+
+(define (fv x)
+ (vector-ref x 1))
+
+(define-class <c1> ()
+ x)
+
+(define-class <c2> (<c1>)
+ )
+
+(define-class <c3> (<c1>)
+ )
+
+(define fx1 (slot-accessor <c1> 'X))
+(define fx2 (slot-accessor <c1> 'X))
+(define fx3 (slot-accessor <c1> 'X))
+
+(define-generic fx1* (instance))
+(define-generic fx2* (instance))
+(define-generic fx3* (instance))
+(let ((method (slot-accessor-method <c1> 'X)))
+ (add-method fx1* method)
+ (add-method fx2* method)
+ (add-method fx3* method))
+
+(define-generic g1 (instance))
+(define-method g1 ((instance <c1>)) instance)
+(define (get-g1) g1)
+
+(define-generic g2 (instance))
+(define-method g2 ((instance <c1>)) instance)
+(define-method g2 ((instance <c2>)) instance)
+
+(define-generic g3 (instance other))
+(define-method g3 ((instance <c1>) other) other instance)
+\f
+(define (null-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000)))))
+
+(define (f1-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (f1 i1))))
+
+(define (f2-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (f2 i1 i2))))
+
+(define (f3-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (rf i1))))
+
+(define (f4-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (rf i1 i2))))
+
+(define (f5-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '())))
+ (f5 (get-f5)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (f5 i1))))
+
+(define (f6-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '())))
+ (f6 (get-f6 0)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (f6 i1))))
+
+(define (fv-test)
+ (let ((i1 (vector 'A 'B)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (fv i1))))
+\f
+(define (fx1-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (set-slot-value! i1 'X 0)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (fx1 i1))))
+
+(define (fx2-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (set-slot-value! i1 'X 0)
+ (set-slot-value! i2 'X 0)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (fx2 i1)
+ (fx2 i2))))
+
+(define (fx3-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (set-slot-value! i1 'X 0)
+ (set-slot-value! i2 'X 0)
+ (set-slot-value! i3 'X 0)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (fx3 i1)
+ (fx3 i2)
+ (fx3 i3))))
+
+(define (fx1*-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (set-slot-value! i1 'X 0)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (fx1* i1))))
+
+(define (fx2*-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (set-slot-value! i1 'X 0)
+ (set-slot-value! i2 'X 0)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (fx2* i1)
+ (fx2* i2))))
+
+(define (fx3*-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (set-slot-value! i1 'X 0)
+ (set-slot-value! i2 'X 0)
+ (set-slot-value! i3 'X 0)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (fx3* i1)
+ (fx3* i2)
+ (fx3* i3))))
+\f
+(define (g1-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (g1 i1))))
+
+(define (g2-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (g2 i1)
+ (g2 i2))))
+
+(define (g3-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '()))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (g3 i1 i2))))
+
+(define (g4-test)
+ (let ((i1 ((instance-constructor <c1> '())))
+ (i2 ((instance-constructor <c2> '())))
+ (i3 ((instance-constructor <c3> '())))
+ (g1 (get-g1)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i 100000))
+ (g1 i1))))
+
+(define (run-test test)
+ (test) ;warm up
+ (let loop ((n 3) (time 0))
+ (if (= n 0)
+ (/ time 300)
+ (begin
+ (gc-flip)
+ (let ((process-start (process-time-clock)))
+ (test)
+ (let ((process-end (process-time-clock)))
+ (loop (- n 1)
+ (+ time (- process-end process-start)))))))))
+
+(define (run-tests)
+ (let ((f1-time (run-test f1-test)))
+ (let ((report
+ (lambda (name time scale)
+ (fluid-let ((flonum-unparser-cutoff '(ABSOLUTE 2)))
+ (newline)
+ (write name)
+ (write-string "-test:\t")
+ (write (exact->inexact time))
+ (write-string "\t")
+ (write (exact->inexact (/ (/ time scale) f1-time)))))))
+ (report 'f1 f1-time 1)
+ (for-each (lambda (name test scale)
+ (report name (run-test test) scale))
+ '(f2 f3 f4 f5 f6 fv fx1 fx2 fx3 fx1* fx2* fx3* g1 g2 g3 g4)
+ (list f2-test f3-test f4-test f5-test f6-test fv-test
+ fx1-test fx2-test fx3-test fx1*-test fx2*-test fx3*-test
+ g1-test g2-test g3-test g4-test)
+ '(1 1 1 1 1 1 1 2 3 1 2 3 1 2 1 1)))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: printer.scm,v 1.1 1997/06/04 06:09:14 cph Exp $
+;;;
+;;; Copyright (c) 1996 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Printer Support
+
+(declare (usual-integrations))
+\f
+(define write-instance
+ (make-generic-procedure 2 'WRITE-INSTANCE))
+
+(add-method write-instance
+ (make-method (list <instance>)
+ (lambda (instance port)
+ (write-instance-helper 'INSTANCE instance port
+ (lambda ()
+ (let ((name (class-name (instance-class instance))))
+ (if name
+ (begin
+ (write-string " of " port)
+ (write name port)))))))))
+#|
+(add-method write-instance
+ (make-method (list <class>)
+ (lambda (class port)
+ (write-instance-helper 'CLASS class port
+ (lambda ()
+ (let ((name (class-name class)))
+ (if name
+ (begin
+ (write-char #\space port)
+ (write name port)))))))))
+|#
+(add-method write-instance
+ (make-method (list <generic-procedure>)
+ (lambda (procedure port)
+ (write-instance-helper 'GENERIC-PROCEDURE procedure port
+ (lambda ()
+ (let ((name (generic-procedure-name procedure)))
+ (if name
+ (begin
+ (write-char #\space port)
+ (write name port)))))))))
+
+(let ((install
+ (lambda (class name)
+ (add-method write-instance
+ (make-method (list class)
+ (lambda (object port)
+ (write-instance-helper name object port #f)))))))
+ (install <method> 'METHOD)
+ (install <chained-method> 'CHAINED-METHOD)
+ (install <computed-method> 'COMPUTED-METHOD)
+ (install <computed-emp> 'COMPUTED-EMP)
+ (install <%record> '%RECORD))
+
+(add-method write-instance
+ (make-method (list <record>)
+ (lambda (record port)
+ (write-instance-helper (record-type-name (record-type-descriptor record))
+ record port #f))))
+
+(add-method write-instance
+ (make-method (list <dispatch-tag>)
+ (lambda (tag port)
+ (write-instance-helper 'DISPATCH-TAG tag port
+ (lambda ()
+ (write-char #\space port)
+ (write (dispatch-tag-contents tag) port))))))
+
+(define (write-instance-helper name object port thunk)
+ (write-string "#[" port)
+ (display name port)
+ (if object
+ (begin
+ (write-char #\space port)
+ (write (hash object) port)))
+ (if thunk
+ (thunk))
+ (write-char #\] port))
+\f
+(add-generic-procedure-generator unparse-record
+ (lambda (generic tags)
+ generic
+ (and (let ((class (dispatch-tag-contents (cadr tags))))
+ (and (class? class)
+ (subclass? class <instance>)))
+ (lambda (state instance)
+ (with-current-unparser-state state
+ (lambda (port)
+ (write-instance instance port)))))))
+
+(add-generic-procedure-generator pp-description
+ (lambda (generic tags)
+ generic
+ (and (let ((class (dispatch-tag-contents (car tags))))
+ (and (class? class)
+ (subclass? class <instance>)))
+ instance-description)))
+
+(define (instance-description instance)
+ (map (lambda (slot)
+ (let ((name (slot-name slot)))
+ (cons name
+ (if (slot-initialized? instance name)
+ (list (slot-value instance name))
+ '()))))
+ (class-slots (instance-class instance))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: slot.scm,v 1.1 1997/06/04 06:09:18 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Instance Slots
+
+(declare (usual-integrations))
+\f
+(define-structure (slot-descriptor (conc-name slot-descriptor/))
+ (name #f read-only #t)
+ (class #f read-only #t)
+ (index #f read-only #t)
+ (properties #f read-only #t))
+
+(define (slot-name slot)
+ (guarantee-slot-descriptor slot 'SLOT-NAME)
+ (slot-descriptor/name slot))
+
+(define (slot-class slot)
+ (guarantee-slot-descriptor slot 'SLOT-CLASS)
+ (slot-descriptor/class slot))
+
+(define (slot-index slot)
+ (guarantee-slot-descriptor slot 'SLOT-INDEX)
+ (slot-descriptor/index slot))
+
+(define (slot-property slot key default)
+ (let ((entry (assq key (slot-descriptor/properties slot))))
+ (if entry
+ (cdr entry)
+ default)))
+
+(define (slot-properties slot)
+ (alist-copy (slot-descriptor/properties slot)))
+
+(define (slot-initializer slot)
+ (slot-property slot 'INITIALIZER #f))
+
+(define (slot-initial-value slot)
+ (slot-property slot 'INITIAL-VALUE record-slot-uninitialized))
+
+(define (slot-initial-value? slot)
+ (not (eq? record-slot-uninitialized (slot-initial-value slot))))
+
+(define (slot-allocation slot)
+ (slot-property slot 'ALLOCATION 'INSTANCE))
+
+(define (guarantee-slot-descriptor slot name)
+ (if (not (slot-descriptor? slot))
+ (error:wrong-type-argument slot "slot descriptor" name)))
+
+(add-generic-procedure-generator %record-slot-index
+ (lambda (generic tags)
+ generic
+ (and (class? (dispatch-tag-contents (car tags)))
+ (lambda (instance name)
+ (let ((slot (class-slot (object-class instance) name #f)))
+ (and slot
+ (slot-index slot)))))))
+
+(add-generic-procedure-generator %record-slot-names
+ (lambda (generic tags)
+ generic
+ (and (class? (dispatch-tag-contents (car tags)))
+ (lambda (instance)
+ (map slot-name (class-slots (object-class instance)))))))
+\f
+;;;; Slot Accessors
+
+(define (method-constructor make-generator)
+ (lambda (class name)
+ (make-computed-method (list class)
+ (let ((generator (make-generator name)))
+ (lambda classes
+ (generator #f (map class->dispatch-tag classes)))))))
+
+(define slot-accessor-method (method-constructor %record-accessor-generator))
+(define slot-modifier-method (method-constructor %record-modifier-generator))
+(define slot-initpred-method (method-constructor %record-initpred-generator))
+
+(define (accessor-constructor arity make-method)
+ (lambda (class name)
+ (let ((generic (make-generic-procedure arity)))
+ (add-method generic (make-method class name))
+ generic)))
+
+(define slot-accessor (accessor-constructor 1 slot-accessor-method))
+(define slot-modifier (accessor-constructor 2 slot-modifier-method))
+(define slot-initpred (accessor-constructor 1 slot-initpred-method))
+
+(define (install-slot-accessor-methods class)
+ (for-each
+ (lambda (name)
+ (let* ((slot (class-slot class name #t))
+ (install
+ (lambda (keyword maker)
+ (let ((accessor (slot-property slot keyword #f)))
+ (if accessor
+ (add-method accessor (maker class name)))))))
+ (install 'ACCESSOR slot-accessor-method)
+ (install 'MODIFIER slot-modifier-method)
+ (install 'INITPRED slot-initpred-method)))
+ (class-direct-slot-names class)))
+
+(define (slot-value instance name)
+ (%record-ref instance (compute-slot-index instance name 'SLOT-VALUE)))
+
+(define (set-slot-value! instance name value)
+ (%record-set! instance
+ (compute-slot-index instance name 'SET-SLOT-VALUE!)
+ value))
+
+(define (slot-initialized? instance name)
+ (not (eq? record-slot-uninitialized
+ (%record-ref instance
+ (compute-slot-index instance name
+ 'SLOT-INITIALIZED?)))))
+
+(define (compute-slot-index instance name error-name)
+ (or (%record-slot-index instance name)
+ (error:bad-range-argument name error-name)))
+\f
+;;;; Slot Arguments
+
+(define (canonicalize-slot-argument argument caller)
+ (cond ((symbol? argument)
+ (list argument))
+ ((and (pair? argument)
+ (symbol? (car argument))
+ (slot-argument-plist? (cdr argument)))
+ argument)
+ (else
+ (error:bad-range-argument argument caller))))
+
+(define (slot-argument-plist? object)
+ (let loop ((l1 object) (l2 object))
+ (if (pair? l1)
+ (and (not (eq? (cdr l1) l2))
+ (symbol? (car l1))
+ (pair? (cdr l1))
+ (loop (cddr l1) (cdr l2)))
+ (null? l1))))
+
+(define (compute-slot-descriptor class slots index)
+ (call-with-values
+ (lambda ()
+ (parse-slot-argument (merge-slot-arguments slots)))
+ (lambda (name properties)
+ (make-slot-descriptor name class index properties))))
+
+(define (merge-slot-arguments slots)
+ (if (null? (cdr slots))
+ (car slots)
+ (let ((slots (reverse slots)))
+ (let ((result (list-copy (car slots))))
+ (for-each (lambda (slot)
+ (merge-slot-arguments! slot result))
+ (cdr slots))
+ result))))
+
+(define (merge-slot-arguments! x y)
+ (do ((x (cdr x) (cddr x)))
+ ((null? x))
+ (let ((key (car x))
+ (value (cadr x)))
+ (let loop ((z (cdr y)))
+ (cond ((null? z) (set-cdr! y (cons* key value (cdr y))))
+ ((eq? key (car z)) (set-car! (cdr z) value))
+ (else (loop (cddr z))))))))
+
+(define (parse-slot-argument argument)
+ (let loop ((plist (cdr argument)) (properties '()))
+ (if (null? plist)
+ (values (car argument) properties)
+ (loop (cddr plist)
+ (cons (cons (car plist) (cadr plist)) properties)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: sos.pkg,v 1.1 1997/06/04 06:09:57 cph Exp $
+
+Copyright (c) 1995-97 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Packaging for Scheme Object System
+\f
+(global-definitions "../runtime/runtime")
+
+(define-package (sos)
+ (files)
+ (parent ()))
+
+(define-package (sos slot)
+ (files "slot")
+ (parent ())
+ (export ()
+ set-slot-value!
+ slot-accessor
+ slot-accessor-method
+ slot-class
+ slot-descriptor?
+ slot-index
+ slot-initial-value
+ slot-initial-value?
+ slot-initialized?
+ slot-initializer
+ slot-initpred
+ slot-initpred-method
+ slot-modifier
+ slot-modifier-method
+ slot-name
+ slot-properties
+ slot-property
+ slot-value)
+ (export (sos class)
+ canonicalize-slot-argument
+ compute-slot-descriptor
+ install-slot-accessor-methods))
+
+(define-package (sos class)
+ (files "class")
+ (parent ())
+ (export ()
+ <%record>
+ <bignum>
+ <boolean>
+ <char>
+ <class>
+ <complex>
+ <dispatch-tag>
+ <entity>
+ <exact-complex>
+ <exact-integer>
+ <exact-rational>
+ <exact-real>
+ <exact>
+ <fixnum>
+ <flonum-vector>
+ <flonum>
+ <generic-procedure>
+ <inexact-complex>
+ <inexact-integer>
+ <inexact-rational>
+ <inexact-real>
+ <inexact>
+ <instance>
+ <integer>
+ <number>
+ <object>
+ <pair>
+ <procedure>
+ <rational>
+ <ratnum>
+ <real>
+ <recnum>
+ <record>
+ <string>
+ <symbol>
+ <vector>
+ class->dispatch-tag
+ class-direct-slot-names
+ class-direct-superclasses
+ class-name
+ class-precedence-list
+ class-slot
+ class-slots
+ class?
+ dispatch-tag->class
+ instance-of?
+ instance-predicate
+ make-class
+ make-trivial-subclass
+ object-class
+ record-class
+ record-type-class
+ subclass?))
+
+(define-package (sos instance)
+ (files "instance")
+ (parent ())
+ (export ()
+ instance-class
+ instance-constructor
+ instance?))
+
+(define-package (sos method)
+ (files "method")
+ (parent ())
+ (export ()
+ <chained-method>
+ <computed-emp>
+ <computed-method>
+ <method>
+ add-method
+ add-methods
+ chained-method?
+ compute-effective-method-procedure
+ compute-method
+ computed-emp-key
+ computed-emp?
+ computed-method?
+ delete-method
+ generic-procedure-methods
+ make-chained-method
+ make-computed-emp
+ make-computed-method
+ make-method
+ method-applicable?
+ method-procedure
+ method-specializers
+ method?
+ specializer=?
+ specializer?
+ specializers=?
+ specializers?
+ union-specializer
+ union-specializer-classes
+ union-specializer=?
+ union-specializer?))
+
+(define-package (sos printer)
+ (files "printer")
+ (parent ())
+ (export ()
+ write-instance
+ write-instance-helper))
+
+(define-package (sos macros)
+ (files "macros")
+ (parent ()))
\ No newline at end of file
projects / mit-scheme.git / commitdiff