From aeb5fecd15a41aac46bbf2e7166c1e035c50319d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 13 Mar 2003 21:50:40 +0000 Subject: [PATCH] Change DEFINE-STRUCTURE to use new procedures DEFINE-STRUCTURE/KEYWORD-CONSTRUCTOR and DEFINE-STRUCTURE/DEFAULT-VALUE. --- v7/src/runtime/defstr.scm | 144 ++++++++++++++----------------------- v7/src/runtime/record.scm | 101 ++++++++++---------------- v7/src/runtime/runtime.pkg | 7 +- 3 files changed, 94 insertions(+), 158 deletions(-) diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm index 4d2965634..32e908f25 100644 --- a/v7/src/runtime/defstr.scm +++ b/v7/src/runtime/defstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: defstr.scm,v 14.52 2003/03/13 20:06:41 cph Exp $ +$Id: defstr.scm,v 14.53 2003/03/13 21:50:00 cph Exp $ Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology Copyright 1993,1994,1995,1996,1997,2000 Massachusetts Institute of Technology @@ -561,6 +561,9 @@ differences: (offset structure/offset) (slots structure/slots)) +(define-integrable (structure/record-type? structure) + (eq? (structure/physical-type structure) 'RECORD)) + (define-record-type (make-parser-context name environment closing-environment) parser-context? @@ -661,61 +664,33 @@ differences: (define (constructor-definitions structure) `(,@(map (lambda (constructor) - (if (pair? (cdr constructor)) - (constructor-definition/boa structure - (car constructor) - (cadr constructor)) - (constructor-definition/default structure (car constructor)))) + (constructor-definition/boa + structure + (car constructor) + (if (pair? (cdr constructor)) + (cadr constructor) + (map slot/name (structure/slots structure))))) (structure/constructors structure)) - ,@(map (lambda (constructor) - (constructor-definition/keyword structure (car constructor))) - (structure/keyword-constructors structure)))) - -(define (constructor-definition/default structure name) - (let ((slot-names (map slot/name (structure/slots structure)))) - (make-constructor structure name slot-names - (lambda (tag-expression) - `(,(absolute (case (structure/physical-type structure) - ((RECORD) '%RECORD) - ((VECTOR) 'VECTOR) - ((LIST) 'LIST)) - (structure/context structure)) - ,@(constructor-prefix-slots structure tag-expression) - ,@slot-names))))) + ,@(let ((context (structure/context structure))) + (let ((p (absolute (if (structure/record-type? structure) + 'RECORD-KEYWORD-CONSTRUCTOR + 'DEFINE-STRUCTURE/KEYWORD-CONSTRUCTOR) + context)) + (t (close (structure/type-descriptor structure) context))) + (map (lambda (constructor) `(DEFINE ,(car constructor) (,p ,t))) + (structure/keyword-constructors structure)))))) -(define (constructor-definition/keyword structure name) - (let ((context (structure/context structure))) - (let ((type-descriptor - (close (structure/type-descriptor structure) context))) - (if (eq? (structure/physical-type structure) 'RECORD) - `(DEFINE ,name - (,(absolute 'RECORD-KEYWORD-CONSTRUCTOR context) - ,type-descriptor)) - (make-constructor structure name 'KEYWORD-LIST - (lambda (tag-expression) - (let ((list-cons - `(,@(constructor-prefix-slots structure tag-expression) - (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER context) - ,type-descriptor - KEYWORD-LIST)))) - (case (structure/physical-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) - (let ((type (structure/physical-type structure)) - (context (structure/context structure))) - `(,(absolute (case type + (let ((context (structure/context structure))) + `(,(absolute (case (structure/physical-type structure) ((RECORD) '%RECORD) ((VECTOR) 'VECTOR) ((LIST) 'LIST)) context) - ,@(constructor-prefix-slots structure tag-expression) + ,@(if (structure/tagged? structure) `(,tag-expression) '()) + ,@(make-list (structure/offset structure) '#F) ,@(call-with-values (lambda () (parse-mit-lambda-list lambda-list)) (lambda (required optional rest) (let ((name->slot @@ -726,53 +701,39 @@ differences: (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 - (cond ((eq? type 'RECORD) - `(,(absolute - 'RECORD-TYPE-DEFAULT-VALUE - context) - ,(close - (structure/type-descriptor - structure) - context) - ',name)) - (tag-expression - `(,(absolute - 'STRUCTURE-TAG/DEFAULT-VALUE - context) - ,tag-expression - ',type - ',name)) - (else - (close (slot/default slot) - context))))) - (if (memq slot optional) - `(IF (DEFAULT-OBJECT? ,name) ,dv ,name) - dv))))) + (let* ((name (slot/name slot)) + (dv (default-value-expr structure name))) + (cond ((or (memq slot required) + (eq? slot rest)) + name) + ((memq slot optional) + `(IF (DEFAULT-OBJECT? ,name) ,dv ,name)) + (else dv)))) (structure/slots structure))))))))))) (define (make-constructor structure name lambda-list generate-body) - (let ((tag-expression - (close (structure/tag-expression structure) - (structure/context structure)))) - (if (eq? (structure/physical-type structure) 'RECORD) - (let ((tag (make-synthetic-identifier 'TAG))) - `(DEFINE ,name - (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression))) - (NAMED-LAMBDA (,name ,@lambda-list) - ,(generate-body tag))))) + (let* ((context (structure/context structure)) + (tag-expression (close (structure/tag-expression structure) context))) + (if (structure/record-type? structure) + `(DEFINE ,name + (LET ((TAG + (,(absolute 'RECORD-TYPE-DISPATCH-TAG context) + ,tag-expression))) + ,(capture-syntactic-environment + (lambda (environment) + `(NAMED-LAMBDA (,name ,@lambda-list) + ,(generate-body (close-syntax 'TAG environment))))))) `(DEFINE (,name ,@lambda-list) ,(generate-body tag-expression))))) -(define (constructor-prefix-slots structure tag-expression) - (let ((offsets (make-list (structure/offset structure) '#F))) - (if (structure/tagged? structure) - (cons tag-expression offsets) - offsets))) +(define (default-value-expr structure name) + (let ((context (structure/context structure))) + `(,(absolute (if (structure/record-type? structure) + 'RECORD-TYPE-DEFAULT-VALUE + 'DEFINE-STRUCTURE/DEFAULT-VALUE) + context) + ,(close (structure/type-descriptor structure) context) + ',name))) (define (copier-definitions structure) (let ((copier-name (structure/copier structure))) @@ -818,8 +779,7 @@ differences: '()))) (define (type-definitions structure) - (let ((physical-type (structure/physical-type structure)) - (type-name (structure/type-descriptor structure)) + (let ((type-name (structure/type-descriptor structure)) (tag-expression (structure/tag-expression structure)) (slots (structure/slots structure)) (context (structure/context structure)) @@ -831,14 +791,14 @@ differences: `(LAMBDA () ,(close (slot/default slot) context))) slots))) `((DEFINE ,type-name - ,(if (eq? physical-type 'RECORD) + ,(if (structure/record-type? structure) `(,(absolute 'MAKE-RECORD-TYPE context) ',name ',field-names (LIST ,@inits) ,(close print-procedure context)) `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context) - ',physical-type + ',(structure/physical-type structure) ',name ',field-names ',(map slot/index slots) diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm index 812273c2d..1afbbe14f 100644 --- a/v7/src/runtime/record.scm +++ b/v7/src/runtime/record.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: record.scm,v 1.41 2003/03/13 20:13:03 cph Exp $ +$Id: record.scm,v 1.42 2003/03/13 21:50:15 cph Exp $ Copyright 1989,1990,1991,1993,1994,1996 Massachusetts Institute of Technology Copyright 1997,2002,2003 Massachusetts Institute of Technology @@ -565,13 +565,9 @@ USA. (eq? (structure-type/physical-type structure-type) type) structure-type)))) -(define (structure-tag/default-value tag type field-name) - (let ((type (tag->structure-type tag type))) - (if (not type) - (error:wrong-type-argument tag "structure tag" - 'STRUCTURE-TAG/DEFAULT-VALUE)) - ((vector-ref (structure-type/default-inits type) - (structure-type/field-name-index type field-name))))) +(define (define-structure/default-value type field-name) + ((vector-ref (structure-type/default-inits type) + (structure-type/field-name-index type field-name)))) ;;;; Support for safe accessors @@ -660,61 +656,42 @@ USA. (structure-type/name type) `(,accessor-type ,type ',field-name))))) -(define (define-structure/keyword-parser type arguments) - (let ((names (structure-type/field-names type)) - (inits (structure-type/default-inits type))) - (let ((n (vector-length names))) - (let* ((unseen (list 'UNSEEN)) - (values (make-vector n unseen))) - (do ((args arguments (cddr args))) - ((not (pair? args))) - (if (not (pair? (cdr args))) - (error "Keyword list does not have even length:" arguments)) - (let ((i (structure-type/field-name-index type (car args)))) - (if (eq? (vector-ref values i) unseen) - (vector-set! values i (cadr args))))) - (do ((i (fix:- n 1) (fix:- i 1)) - (l '() - (cons (if (eq? (vector-ref values i) unseen) - (vector-ref values i) - ((vector-ref inits i))) - l))) - ((not (fix:>= i 0)) l)))))) - -(define (define-structure/keyword-parser* type arguments) +(define (define-structure/keyword-constructor type) (let ((names (structure-type/field-names type)) (indexes (structure-type/field-indexes type)) (inits (structure-type/default-inits type)) - (v (vector-cons (structure-type/length type) #f))) + (tag (structure-type/tag type)) + (len (structure-type/length type))) (let ((n (vector-length names))) - (let ((tag (structure-type/tag type))) - (if tag - (vector-set! v 0 tag))) - (let ((seen? (make-vector n #f))) - (do ((args arguments (cddr args))) - ((not (pair? args))) - (if (not (pair? (cdr args))) - (error "Keyword list does not have even length:" arguments)) - (let ((field-name (car args))) - (let loop ((i 0)) - (if (not (fix:< i n)) - (error:no-such-slot type field-name)) - (if (eq? (vector-ref names i) field-name) - (if (not (vector-ref seen? i)) - (begin - (vector-set! v - (vector-ref indexes i) - (cadr args)) - (vector-set! seen? i #t))) - (loop (fix:+ i 1)))))) - (do ((i 0 (fix:+ i 1))) - ((not (fix:< i n))) - (if (not (vector-ref seen? i)) - (vector-set! v - (vector-ref indexes i) - ((vector-ref inits i)))))) - (if (eq? (structure-type/physical-type type) 'LIST) - (do ((i (fix:- n 1) (fix:- i 1)) - (l '() (cons (vector-ref v i) l))) - ((not (fix:>= i 0)) l)) - v)))) \ No newline at end of file + (lambda arguments + (let ((v (vector-cons len #f))) + (if tag + (vector-set! v 0 tag)) + (let ((seen? (make-vector n #f))) + (do ((args arguments (cddr args))) + ((not (pair? args))) + (if (not (pair? (cdr args))) + (error "Keyword list does not have even length:" arguments)) + (let ((field-name (car args))) + (let loop ((i 0)) + (if (not (fix:< i n)) + (error:no-such-slot type field-name)) + (if (eq? (vector-ref names i) field-name) + (if (not (vector-ref seen? i)) + (begin + (vector-set! v + (vector-ref indexes i) + (cadr args)) + (vector-set! seen? i #t))) + (loop (fix:+ i 1)))))) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i n))) + (if (not (vector-ref seen? i)) + (vector-set! v + (vector-ref indexes i) + ((vector-ref inits i)))))) + (if (eq? (structure-type/physical-type type) 'LIST) + (do ((i (fix:- len 1) (fix:- i 1)) + (list '() (cons (vector-ref v i) list))) + ((not (fix:>= i 0)) list)) + v)))))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 9d9c7da2a..8e6ae4ef1 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.437 2003/03/13 20:17:15 cph Exp $ +$Id: runtime.pkg,v 14.438 2003/03/13 21:50:40 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -2662,8 +2662,8 @@ USA. %record-tag %record? copy-record - define-structure/keyword-parser - define-structure/keyword-parser* + define-structure/default-value + define-structure/keyword-constructor define-structure/list-accessor define-structure/list-modifier define-structure/vector-accessor @@ -2694,7 +2694,6 @@ USA. record? 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