From b0ce333406c1dd6b6469ee841f65999c4a1d269b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 4 Jun 1997 06:09:57 +0000 Subject: [PATCH] Initial revision --- v7/src/sos/class.scm | 411 ++++++++++++++++++++++++++++++++++ v7/src/sos/compile.scm | 111 ++++++++++ v7/src/sos/instance.scm | 158 +++++++++++++ v7/src/sos/load.scm | 52 +++++ v7/src/sos/macros.scm | 441 ++++++++++++++++++++++++++++++++++++ v7/src/sos/method.scm | 456 ++++++++++++++++++++++++++++++++++++++ v7/src/sos/microbench.scm | 288 ++++++++++++++++++++++++ v7/src/sos/printer.scm | 139 ++++++++++++ v7/src/sos/slot.scm | 207 +++++++++++++++++ v7/src/sos/sos.pkg | 180 +++++++++++++++ 10 files changed, 2443 insertions(+) create mode 100644 v7/src/sos/class.scm create mode 100644 v7/src/sos/compile.scm create mode 100644 v7/src/sos/instance.scm create mode 100644 v7/src/sos/load.scm create mode 100644 v7/src/sos/macros.scm create mode 100644 v7/src/sos/method.scm create mode 100644 v7/src/sos/microbench.scm create mode 100644 v7/src/sos/printer.scm create mode 100644 v7/src/sos/slot.scm create mode 100644 v7/src/sos/sos.pkg diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm new file mode 100644 index 000000000..2cf422524 --- /dev/null +++ b/v7/src/sos/class.scm @@ -0,0 +1,411 @@ +;;; -*-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)) + +(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 ) + 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 + (let ((class (%make-class ' '() '()))) + (set-class/precedence-list! class (list class)) + (set-class/slots! class '()) + (set-class/dispatch-tag! class (make-dispatch-tag class)) + class)) + +(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))) + +(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)))))))))) + +;;;; 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))))))))) + +(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))) + +;;;; Built-in Classes + +(define (make-class ' (list ) '())) + +(let-syntax + ((define-primitive-class + (macro (name . superclasses) + `(DEFINE ,name (MAKE-CLASS ',name (LIST ,@superclasses) '()))))) + +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class <%record> ) +(define-primitive-class <%record>) +(define-primitive-class <%record>) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) + +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) + +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) + +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) + +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) + +(define-primitive-class ) +(define-primitive-class ) +(define-primitive-class ) + +) + +(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 )))) + +(define (make-record-type-class type) + (make-class (string->symbol (string-append "<" (record-type-name type) ">")) + (list ) + (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 ) + (assign-type 'CHARACTER ) + (assign-type 'PAIR ) + (assign-type 'RECORD <%record>) + (assign-type 'DISPATCH-TAG ) + (assign-type 'STRING ) + (assign-type 'INTERNED-SYMBOL ) + (assign-type 'UNINTERNED-SYMBOL ) + (assign-type 'VECTOR ) + + (assign-type 'COMPILED-PROCEDURE ) + (assign-type 'EXTENDED-PROCEDURE ) + (assign-type 'PRIMITIVE ) + (assign-type 'PROCEDURE ) + (assign-type 'ENTITY ) + + (if (> microcode-id/version 11) + (begin + (assign-type 'POSITIVE-FIXNUM ) + (assign-type 'NEGATIVE-FIXNUM )) + (assign-type 'FIXNUM )) + (assign-type 'BIGNUM ) + (assign-type 'RATNUM ) + (assign-type 'FLONUM ) + (assign-type 'FLONUM-VECTOR ) + (assign-type 'RECNUM )) + +(hash-table/put! built-in-class-table + standard-generic-procedure-tag + ) + +(define (object-class )) + +(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 diff --git a/v7/src/sos/compile.scm b/v7/src/sos/compile.scm new file mode 100644 index 000000000..e71f05496 --- /dev/null +++ b/v7/src/sos/compile.scm @@ -0,0 +1,111 @@ +;;; -*-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 diff --git a/v7/src/sos/instance.scm b/v7/src/sos/instance.scm new file mode 100644 index 000000000..2cba70f43 --- /dev/null +++ b/v7/src/sos/instance.scm @@ -0,0 +1,158 @@ +;;; -*-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)) + +;;;; 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 '())))))) + +(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 diff --git a/v7/src/sos/load.scm b/v7/src/sos/load.scm new file mode 100644 index 000000000..daacc6761 --- /dev/null +++ b/v7/src/sos/load.scm @@ -0,0 +1,52 @@ +;;; -*-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 diff --git a/v7/src/sos/macros.scm b/v7/src/sos/macros.scm new file mode 100644 index 000000000..f6a9fe44c --- /dev/null +++ b/v7/src/sos/macros.scm @@ -0,0 +1,441 @@ +;;; -*-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)) + +(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)))))))) + +(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))) + +(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)))))) + +(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? ' (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 ' 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? ' (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)))) + +(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)) + +(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)))) + +(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 diff --git a/v7/src/sos/method.scm b/v7/src/sos/method.scm new file mode 100644 index 000000000..9f9e425ae --- /dev/null +++ b/v7/src/sos/method.scm @@ -0,0 +1,456 @@ +;;; -*-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)) + +;;;; 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)) + +;;;; 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)) + '()))) + +;;;; 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)))))) + +(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)))))))))))) + +;;;; 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? (car s2)) + (loop (cdr s2)))))) + ((null? s2) + (let loop ((s1 s1)) + (and (eq? (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)))) + +(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))))) + +;;;; Method Types + +(define + (make-class ' '() '(SPECIALIZERS PROCEDURE))) + +(define make-method + (let ((%make (instance-constructor '(SPECIALIZERS PROCEDURE)))) + (lambda (specializers procedure) + (%make (guarantee-specializers specializers #t 'MAKE-METHOD) + procedure)))) + +(define method? + (instance-predicate )) + +(define method-specializers + (make-generic-procedure 1 'METHOD-SPECIALIZERS)) + +(define method-procedure + (make-generic-procedure 1 'METHOD-PROCEDURE)) + + +(define + (make-class ' (list ) '())) + +(define make-chained-method + (let ((%make + (instance-constructor '(SPECIALIZERS PROCEDURE)))) + (lambda (specializers procedure) + (%make (guarantee-specializers specializers #t 'MAKE-CHAINED-METHOD) + procedure)))) + +(define chained-method? + (instance-predicate )) + + +(define + (make-class ' (list ) '())) + +(define make-computed-method + (let ((%make + (instance-constructor '(SPECIALIZERS PROCEDURE)))) + (lambda (specializers procedure) + (%make (guarantee-specializers specializers #t 'MAKE-COMPUTED-METHOD) + procedure)))) + +(define computed-method? + (instance-predicate )) + + +(define + (make-class ' (list ) '(KEY))) + +(define make-computed-emp + (let ((%make + (instance-constructor '(KEY SPECIALIZERS PROCEDURE)))) + (lambda (key specializers procedure) + (%make key + (guarantee-specializers specializers #t 'MAKE-COMPUTED-EMP) + procedure)))) + +(define computed-emp? + (instance-predicate )) + +(define computed-emp-key + (make-generic-procedure 1 'COMPUTED-EMP-KEY)) + +;;; 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 ) + get-specializers) + (list method-procedure + (list ) + get-procedure) + (list computed-emp-key + (list ) + (%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 'SPECIALIZERS)) + +(add-method method-procedure + (slot-accessor-method 'PROCEDURE)) + +(add-method computed-emp-key + (slot-accessor-method 'KEY)) \ No newline at end of file diff --git a/v7/src/sos/microbench.scm b/v7/src/sos/microbench.scm new file mode 100644 index 000000000..75f107053 --- /dev/null +++ b/v7/src/sos/microbench.scm @@ -0,0 +1,288 @@ +;;; -*-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)) + +(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 () + x) + +(define-class () + ) + +(define-class () + ) + +(define fx1 (slot-accessor 'X)) +(define fx2 (slot-accessor 'X)) +(define fx3 (slot-accessor 'X)) + +(define-generic fx1* (instance)) +(define-generic fx2* (instance)) +(define-generic fx3* (instance)) +(let ((method (slot-accessor-method 'X))) + (add-method fx1* method) + (add-method fx2* method) + (add-method fx3* method)) + +(define-generic g1 (instance)) +(define-method g1 ((instance )) instance) +(define (get-g1) g1) + +(define-generic g2 (instance)) +(define-method g2 ((instance )) instance) +(define-method g2 ((instance )) instance) + +(define-generic g3 (instance other)) +(define-method g3 ((instance ) other) other instance) + +(define (null-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000))))) + +(define (f1-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (f1 i1)))) + +(define (f2-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (f2 i1 i2)))) + +(define (f3-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (rf i1)))) + +(define (f4-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (rf i1 i2)))) + +(define (f5-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '()))) + (f5 (get-f5))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (f5 i1)))) + +(define (f6-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '()))) + (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)))) + +(define (fx1-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (set-slot-value! i1 'X 0) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (fx1 i1)))) + +(define (fx2-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (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 '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (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 '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (set-slot-value! i1 'X 0) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (fx1* i1)))) + +(define (fx2*-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (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 '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (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 (g1-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (g1 i1)))) + +(define (g2-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (g2 i1) + (g2 i2)))) + +(define (g3-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '())))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i 100000)) + (g3 i1 i2)))) + +(define (g4-test) + (let ((i1 ((instance-constructor '()))) + (i2 ((instance-constructor '()))) + (i3 ((instance-constructor '()))) + (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 diff --git a/v7/src/sos/printer.scm b/v7/src/sos/printer.scm new file mode 100644 index 000000000..dfb7e4eb7 --- /dev/null +++ b/v7/src/sos/printer.scm @@ -0,0 +1,139 @@ +;;; -*-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)) + +(define write-instance + (make-generic-procedure 2 'WRITE-INSTANCE)) + +(add-method write-instance + (make-method (list ) + (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 ) + (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 ) + (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) + (install 'CHAINED-METHOD) + (install 'COMPUTED-METHOD) + (install 'COMPUTED-EMP) + (install <%record> '%RECORD)) + +(add-method write-instance + (make-method (list ) + (lambda (record port) + (write-instance-helper (record-type-name (record-type-descriptor record)) + record port #f)))) + +(add-method write-instance + (make-method (list ) + (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)) + +(add-generic-procedure-generator unparse-record + (lambda (generic tags) + generic + (and (let ((class (dispatch-tag-contents (cadr tags)))) + (and (class? class) + (subclass? class ))) + (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-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 diff --git a/v7/src/sos/slot.scm b/v7/src/sos/slot.scm new file mode 100644 index 000000000..7048b62e1 --- /dev/null +++ b/v7/src/sos/slot.scm @@ -0,0 +1,207 @@ +;;; -*-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)) + +(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))))))) + +;;;; 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))) + +;;;; 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 diff --git a/v7/src/sos/sos.pkg b/v7/src/sos/sos.pkg new file mode 100644 index 000000000..9b2751207 --- /dev/null +++ b/v7/src/sos/sos.pkg @@ -0,0 +1,180 @@ +#| -*-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 + +(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> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 () + + + + + 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 -- 2.25.1