From 9467d399dc2e3a46183b2f99ba005f88f772d183 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 11 Mar 2003 05:01:21 +0000 Subject: [PATCH] Change both records and named structures to store default values as thunks in the type structure, which are then called when needed. Introduce new procedures to get the default value for a slot, given the type descriptor, and use them as needed in DEFINE-STRUCTURE, rather than just inserting the default-init expression. Put back the UNPARSER-METHOD argument to MAKE-RECORD-TYPE, and use it in DEFINE-STRUCTURE. Once again, use RECORD-KEYWORD-CONSTRUCTOR in DEFINE-STRUCTURE, this time with better results. --- v7/src/edwin/clscon.scm | 5 +- v7/src/runtime/defstr.scm | 172 +++++++++++++++++++------------------ v7/src/runtime/random.scm | 8 +- v7/src/runtime/runtime.pkg | 8 +- 4 files changed, 103 insertions(+), 90 deletions(-) diff --git a/v7/src/edwin/clscon.scm b/v7/src/edwin/clscon.scm index d19ddc2ab..01bb0411b 100644 --- a/v7/src/edwin/clscon.scm +++ b/v7/src/edwin/clscon.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: clscon.scm,v 1.11 2003/02/14 18:28:11 cph Exp $ +$Id: clscon.scm,v 1.12 2003/03/11 05:01:21 cph Exp $ -Copyright 1986-1999, 2002 Massachusetts Institute of Technology +Copyright 1989,1990,1991,1993,2002,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -55,6 +55,7 @@ USA. name (map car transforms) (map cdr transforms) + #f (unparser/standard-method name))) class)))) (if (not entry) diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm index 281f8ef52..d2dc2e770 100644 --- a/v7/src/runtime/defstr.scm +++ b/v7/src/runtime/defstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: defstr.scm,v 14.48 2003/03/08 04:53:58 cph Exp $ +$Id: defstr.scm,v 14.49 2003/03/11 05:00:41 cph Exp $ Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology Copyright 1993,1994,1995,1996,1997,2000 Massachusetts Institute of Technology @@ -74,7 +74,7 @@ differences: * The INCLUDE option is not implemented. |# - + (define-expander 'DEFINE-STRUCTURE system-global-environment (lambda (form environment closing-environment) (if (not (and (pair? (cdr form)) (list? (cddr form)))) @@ -545,12 +545,6 @@ differences: (else (error "Unrecognized structure slot option:" option)))))) (make-slot name default type read-only?))))) - -(define (get-slot-default slot structure) - (make-syntactic-closure - (parser-context/environment (structure/context structure)) - (map slot/name (structure/slots structure)) - (slot/default slot))) ;;;; Descriptive Structure @@ -703,58 +697,69 @@ differences: ,@slot-names))))) (define (constructor-definition/keyword structure name) - (make-constructor structure name 'KEYWORD-LIST - (lambda (tag-expression) - (let ((context (structure/context structure))) - (let ((list-cons - `(,@(constructor-prefix-slots structure tag-expression) - (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER context) - KEYWORD-LIST - (,(absolute 'LIST context) - ,@(map (lambda (slot) - `(,(absolute 'CONS context) - ',(slot/name slot) - ,(get-slot-default slot structure))) - (structure/slots structure))))))) - (case (structure/type structure) - ((RECORD) - `(,(absolute 'APPLY context) ,(absolute '%RECORD context) - ,@list-cons)) - ((VECTOR) - `(,(absolute 'APPLY context) ,(absolute 'VECTOR context) - ,@list-cons)) - ((LIST) - `(,(absolute 'CONS* context) ,@list-cons)))))))) + (let ((context (structure/context structure))) + (if (eq? (structure/type structure) 'RECORD) + `(DEFINE ,name + (,(absolute 'RECORD-KEYWORD-CONSTRUCTOR context) + ,(close (structure/tag-expression structure) context))) + (make-constructor structure name 'KEYWORD-LIST + (lambda (tag-expression) + (let ((list-cons + `(,@(constructor-prefix-slots structure tag-expression) + (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER context) + ,tag-expression + KEYWORD-LIST)))) + (case (structure/type structure) + ((VECTOR) + `(,(absolute 'APPLY context) ,(absolute 'VECTOR context) + ,@list-cons)) + ((LIST) + `(,(absolute 'CONS* context) ,@list-cons))))))))) (define (constructor-definition/boa structure name lambda-list) (make-constructor structure name lambda-list (lambda (tag-expression) - `(,(absolute (case (structure/type structure) - ((RECORD) '%RECORD) - ((VECTOR) 'VECTOR) - ((LIST) 'LIST)) - (structure/context structure)) - ,@(constructor-prefix-slots structure tag-expression) - ,@(call-with-values (lambda () (parse-mit-lambda-list lambda-list)) - (lambda (required optional rest) - (let ((name->slot - (lambda (name) - (or (slot-assoc name (structure/slots structure)) - (error "Not a defined structure slot:" name))))) - (let ((required (map name->slot required)) - (optional (map name->slot optional)) - (rest (and rest (name->slot rest)))) - (map (lambda (slot) - (cond ((or (memq slot required) - (eq? slot rest)) - (slot/name slot)) - ((memq slot optional) - `(IF (DEFAULT-OBJECT? ,(slot/name slot)) - ,(get-slot-default slot structure) - ,(slot/name slot))) - (else - (get-slot-default slot structure)))) - (structure/slots structure)))))))))) + (let ((type (structure/type structure)) + (context (structure/context structure))) + `(,(absolute (case type + ((RECORD) '%RECORD) + ((VECTOR) 'VECTOR) + ((LIST) 'LIST)) + context) + ,@(constructor-prefix-slots structure tag-expression) + ,@(call-with-values (lambda () (parse-mit-lambda-list lambda-list)) + (lambda (required optional rest) + (let ((name->slot + (lambda (name) + (or (slot-assoc name (structure/slots structure)) + (error "Not a defined structure slot:" name))))) + (let ((required (map name->slot required)) + (optional (map name->slot optional)) + (rest (and rest (name->slot rest)))) + (map (lambda (slot) + (let ((name (slot/name slot))) + (if (or (memq slot required) + (eq? slot rest)) + name + (let ((dv + (if (eq? type 'RECORD) + `(,(absolute + 'RECORD-TYPE-DEFAULT-VALUE + context) + ,(close (structure/tag-expression + structure) + context) + ',name) + `(,(absolute + 'STRUCTURE-TAG/DEFAULT-VALUE + context) + ,tag-expression + ',type + ',name)))) + (if (memq slot optional) + `(IF (DEFAULT-OBJECT? ,name) ,dv ,name) + dv))))) + (structure/slots structure))))))))))) (define (make-constructor structure name lambda-list generate-body) (let* ((context (structure/context structure)) @@ -821,30 +826,33 @@ differences: (if (structure/tagged? structure) (let ((type (structure/type structure)) (type-name (structure/type-descriptor structure)) - (name - (symbol->string - (parser-context/name (structure/context structure)))) - (field-names (map slot/name (structure/slots structure))) - (context (structure/context structure))) - (if (eq? type 'RECORD) - `((DEFINE ,type-name - (,(absolute 'MAKE-RECORD-TYPE context) ',name ',field-names)) - ,@(let ((expression (structure/print-procedure structure))) - (if expression - `((,(absolute 'SET-RECORD-TYPE-UNPARSER-METHOD! context) - ,type-name - ,(close expression context))) - `()))) - (let ((type-expression - `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context) - ',type - ',name - ',field-names - ',(map slot/index (structure/slots structure)) - ,(close (structure/print-procedure structure) context)))) - (if type-name - `((DEFINE ,type-name ,type-expression)) - `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context) - ,(close (structure/tag-expression structure) context) - ,type-expression)))))) + (slots (structure/slots structure)) + (context (structure/context structure)) + (print-procedure (structure/print-procedure structure))) + (let ((name (symbol->string (parser-context/name context))) + (field-names (map slot/name slots)) + (inits + (map (lambda (slot) + `(LAMBDA () ,(close (slot/default slot) context))) + slots))) + (let ((type-expression + (if (eq? type 'RECORD) + `(,(absolute 'MAKE-RECORD-TYPE context) + ',name + ',field-names + (LIST ,@inits) + ,(close print-procedure context)) + `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context) + ',type + ',name + ',field-names + ',(map slot/index (structure/slots structure)) + (LIST ,@inits) + ,(close print-procedure context))))) + (if type-name + `((DEFINE ,type-name ,type-expression)) + `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! + context) + ,(close (structure/tag-expression structure) context) + ,type-expression)))))) '())) \ No newline at end of file diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm index 917229407..b168387c9 100644 --- a/v7/src/runtime/random.scm +++ b/v7/src/runtime/random.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: random.scm,v 14.26 2003/02/14 18:28:33 cph Exp $ +$Id: random.scm,v 14.27 2003/03/11 05:00:48 cph Exp $ -Copyright (c) 1993-2001 Massachusetts Institute of Technology +Copyright 1988,1989,1993,1994,1995,1996 Massachusetts Institute of Technology +Copyright 1998,1999,2000,2001,2003 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -170,7 +171,7 @@ USA. (define (random-state? object) (and (vector? object) - (not (fix:= (vector-length object) 0)) + (fix:= (vector-length object) 4) (eq? (vector-ref object 0) random-state-tag))) (define-integrable random-state-tag @@ -224,4 +225,5 @@ USA. 'RANDOM-STATE '(INDEX BORROW VECTOR) '(1 2 3) + #f (standard-unparser-method 'RANDOM-STATE #f)))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 518234301..efe4853a8 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.435 2003/03/08 02:26:01 cph Exp $ +$Id: runtime.pkg,v 14.436 2003/03/11 05:00:56 cph Exp $ Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology @@ -2683,7 +2683,8 @@ USA. record-keyword-constructor record-modifier record-predicate - record-type-default-values + record-type-default-inits + record-type-default-value record-type-descriptor record-type-dispatch-tag record-type-field-names @@ -2691,8 +2692,9 @@ USA. record-type? record-updater record? - set-record-type-default-values! + set-record-type-default-inits! set-record-type-unparser-method! + structure-tag/default-value unparse-record) (export (runtime record-slot-access) record-type-field-index) -- 2.25.1