From: Chris Hanson Date: Sun, 15 Jun 1997 06:41:44 +0000 (+0000) Subject: Implement support for INITIAL-VALUE slot keyword. Add new generic X-Git-Tag: 20090517-FFI~5138 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=afc5fd854aac3e9b1db8e8cd7edf41ad56a32a01;p=mit-scheme.git Implement support for INITIAL-VALUE slot keyword. Add new generic procedure INITIALIZE-INSTANCE, and give INSTANCE-CONSTRUCTOR and optional boolean argument that, if true, says to call INITIALIZE-INSTANCE on the instance before it is returned. --- diff --git a/v7/src/sos/instance.scm b/v7/src/sos/instance.scm index 41fbc1f47..042c896c1 100644 --- a/v7/src/sos/instance.scm +++ b/v7/src/sos/instance.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: instance.scm,v 1.3 1997/06/04 22:44:21 cph Exp $ +;;; $Id: instance.scm,v 1.4 1997/06/15 06:41:34 cph Exp $ ;;; ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology ;;; @@ -51,7 +51,7 @@ ,@(loop (+ i 1))))) (ELSE ,default))) -(define-macro (fixed-initialization n) +(define-macro (fixed-if-initialization n) (let ((indexes (make-initialized-list n (lambda (index) @@ -74,60 +74,74 @@ indexes initializers))))) -(define-macro (fixed-arity-constructor n) +(define-macro (fixed-iv-initialization n) (let ((indexes (make-initialized-list n (lambda (index) - (intern (string-append "i" (number->string index)))))) - (values + (intern (string-append "n" (number->string index)))))) + (initial-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 + (intern (string-append "i" (number->string index))))))) + `(LET (,@(make-initialized-list n (lambda (index) `(,(list-ref indexes index) (LIST-REF INDEXES ,index)))) - (IF INITIALIZATION - ,(make-lambda `((INITIALIZATION INSTANCE))) - ,(make-lambda '())))))) + ,@(make-initialized-list n + (lambda (index) + `(,(list-ref initial-values index) + (LIST-REF INITIAL-VALUES ,index))))) + (LAMBDA (INSTANCE) + ,@(map (lambda (index initial-value) + `(%RECORD-SET! INSTANCE ,index ,initial-value)) + indexes + initial-values))))) -(define (instance-constructor class slot-names) +(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-initialized-list n + (lambda (index) + `(,(list-ref indexes index) + (LIST-REF INDEXES ,index)))) + ,(let loop + ((alist '((IF-INIT . IF-INIT) + (IV-INIT . IV-INIT) + (CALL-INIT-INSTANCE? . INITIALIZE-INSTANCE))) + (exprs '())) + (if (null? alist) + `(LAMBDA ,values + (LET ((INSTANCE + (OBJECT-NEW-TYPE + (UCODE-TYPE RECORD) + (MAKE-VECTOR INSTANCE-LENGTH + RECORD-SLOT-UNINITIALIZED)))) + (%RECORD-SET! INSTANCE 0 INSTANCE-TAG) + ,@(map (lambda (index value) + `(%RECORD-SET! INSTANCE ,index ,value)) + indexes + values) + ,@(reverse exprs) + INSTANCE)) + `(IF ,(caar alist) + ,(loop (cdr alist) `((,(cdar alist) INSTANCE) ,@exprs)) + ,(loop (cdr alist) exprs))))))) + +(define (instance-constructor class slot-names #!optional call-init-instance?) (let ((slots (map (lambda (name) (class-slot class name #t)) slot-names)) + (call-init-instance? + (if (default-object? call-init-instance?) #f call-init-instance?)) (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))))))))))) + (if-init (make-if-initialization class slots)) + (iv-init (make-iv-initialization class slots))) (let ((indexes (map slot-index slots))) (constructor-case n-values 0 8 fixed-arity-constructor (letrec @@ -142,13 +156,54 @@ (make-vector instance-length record-slot-uninitialized)))) (%record-set! instance 0 instance-tag) - (if initialization (initialization instance)) + (if if-init (if-init instance)) + (if iv-init (iv-init instance)) + (if call-init-instance? (initialize-instance instance)) (do ((indexes indexes (cdr indexes)) (values values (cdr values))) ((null? indexes)) (%record-set! instance (car indexes) (car values))) instance)))) procedure)))))) + +(define (make-if-initialization class arg-slots) + (let ((slots + (list-transform-positive (class-slots class) + (lambda (slot) + (and (slot-initializer slot) + (not (memq slot arg-slots))))))) + (and (not (null? slots)) + (let ((indexes (map slot-index slots)) + (initializers (map slot-initializer slots))) + (constructor-case (length slots) 1 8 fixed-if-initialization + (lambda (instance) + (do ((initializers initializers (cdr initializers)) + (indexes indexes (cdr indexes))) + ((null? initializers) unspecific) + (%record-set! instance + (car indexes) + ((car initializers)))))))))) + +(define (make-iv-initialization class arg-slots) + (let ((slots + (list-transform-positive (class-slots class) + (lambda (slot) + (and (slot-initial-value? slot) + (not (memq slot arg-slots))))))) + (and (not (null? slots)) + (let ((indexes (map slot-index slots)) + (initial-values (map slot-initial-value slots))) + (constructor-case (length slots) 1 8 fixed-iv-initialization + (lambda (instance) + (do ((initial-values initial-values (cdr initial-values)) + (indexes indexes (cdr indexes))) + ((null? initial-values) unspecific) + (%record-set! instance + (car indexes) + (car initial-values))))))))) + +(define initialize-instance + (make-generic-procedure 1 'INITIALIZE-INSTANCE)) (define (instance? object) (and (tagged-vector? object) diff --git a/v7/src/sos/method.scm b/v7/src/sos/method.scm index 07af9ef99..018f3e092 100644 --- a/v7/src/sos/method.scm +++ b/v7/src/sos/method.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: method.scm,v 1.2 1997/06/04 22:24:21 cph Exp $ +;;; $Id: method.scm,v 1.3 1997/06/15 06:41:40 cph Exp $ ;;; ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology ;;; @@ -453,4 +453,8 @@ (slot-accessor-method 'PROCEDURE)) (add-method computed-emp-key - (slot-accessor-method 'KEY)) \ No newline at end of file + (slot-accessor-method 'KEY)) + +(add-method initialize-instance + (make-method (list ) + (lambda (instance) instance unspecific))) \ No newline at end of file diff --git a/v7/src/sos/sos.pkg b/v7/src/sos/sos.pkg index bdba13e61..3e11dfe69 100644 --- a/v7/src/sos/sos.pkg +++ b/v7/src/sos/sos.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: sos.pkg,v 1.2 1997/06/04 22:28:49 cph Exp $ +$Id: sos.pkg,v 1.3 1997/06/15 06:41:44 cph Exp $ Copyright (c) 1995-97 Massachusetts Institute of Technology @@ -127,6 +127,7 @@ MIT in each case. |# (files "instance") (parent ()) (export () + initialize-instance instance-class instance-constructor instance-of?