Change DEFINE-STRUCTURE to use new procedures

DEFINE-STRUCTURE/KEYWORD-CONSTRUCTOR and
DEFINE-STRUCTURE/DEFAULT-VALUE.

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 4d29656347551c5768df11619ad7accf5dd5e517..32e908f25d7ab1d0461a337b424965f295284b08 100644 (file)
--- 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 <parser-context>
     (make-parser-context name environment closing-environment)
     parser-context?
@@ -661,61 +664,33 @@ differences:
 \f
 (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))))))))))
-\f
 (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)))
 \f
 (define (copier-definitions structure)
   (let ((copier-name (structure/copier structure)))
@@ -818,8 +779,7 @@ differences:
        '())))
 \f
 (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 812273c2d0e0292ae3976ebb21efcda522c91d9f..1afbbe14f928e1666d1a58d8495a8b908dcf2219 100644 (file)
--- 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))))
 \f
 ;;;; 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 9d9c7da2a4bc36d36eec22ec07ecccc4336b43a3..8e6ae4ef13c605c9b0b1c668952cb902f1c60b0a 100644 (file)
--- 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)