Change DEFINE-STRUCTURE to generate type descriptors for all

structures, including untagged ones.  This will simplify some
operations that need access to the type descriptor.

The default name to which the type descriptor is bound has been
changed to RTD:foo where "foo" is the structure's root name.

For the runtime cold load, allow TYPE-DESCRIPTOR option to accept #F
as an argument so that the structures defined in "packag.scm" don't
try to build a type descriptor.  This is important because this file
is loaded prior to the type-descriptor infrastructure.  A consequence
of this change is that the TYPE-DESCRIPTOR option no longer implies
tagging.  This is independently specified by the NAMED option, and
these two options are permitted to be used together.

Add TAG and OFFSET fields to the runtime type descriptor for
non-record structures.  In the next revision, this will allow building
more efficient constructors.

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 2efd8edff4064728c6f7507d54cac313113a64cb..39c169846c66b998b1b50435e85d1c312c58ed58 100644 (file)
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.50 2003/03/12 20:40:28 cph Exp $
+$Id: defstr.scm,v 14.51 2003/03/13 03:57:42 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,1997,2000 Massachusetts Institute of Technology
@@ -125,13 +125,8 @@ differences:
          (initial-offset-option (find-option 'INITIAL-OFFSET options)))
       (check-for-duplicate-constructors constructor-options
                                        keyword-constructor-options)
-      (if (and type-descriptor-option named-option)
-         (error "Conflicting structure options:"
-                (option/original type-descriptor-option)
-                (option/original named-option)))
       (let ((tagged?
             (or (not type-option)
-                type-descriptor-option
                 named-option))
            (offset
             (if initial-offset-option
@@ -142,6 +137,12 @@ differences:
        (if (not tagged?)
            (check-for-illegal-untagged predicate-option
                                        print-procedure-option))
+       (if (and type-descriptor-option
+                (not (option/argument type-descriptor-option)))
+           (check-for-illegal-no-descriptor type-descriptor-option
+                                            tagged?
+                                            safe-accessors-option
+                                            keyword-constructor-options))
        (do ((slots slots (cdr slots))
             (index (if tagged? (+ offset 1) offset) (+ index 1)))
            ((not (pair? slots)))
@@ -172,7 +173,7 @@ differences:
                                (option/argument type-option)
                                'RECORD)
                            tagged?
-                           (and tagged? type-name)
+                           type-name
                            (and tagged? tag-expression)
                            (and safe-accessors-option
                                 (option/argument safe-accessors-option))
@@ -197,12 +198,11 @@ differences:
        (let ((option (car options))
              (options (cdr options)))
          (let ((conflict
-                (let ((name (car (option/arguments option))))
+                (let ((name (option/argument option)))
                   (and name
                        (find-matching-item options
                          (lambda (option*)
-                           (eq? (car (option/arguments option*))
-                                name)))))))
+                           (eq? (option/argument option*) name)))))))
            (if conflict
                (error "Conflicting constructor definitions:"
                       (option/original option)
@@ -215,13 +215,12 @@ differences:
           (error "Structure option illegal without TYPE option:"
                  (option/original option)))))
     (if (and named-option
-            (let ((arguments (option/arguments named-option)))
-              (and (pair? arguments)
-                   (not (car arguments)))))
+            (pair? (option/arguments named-option))
+            (not (option/argument named-option)))
        (lose named-option))
     (if initial-offset-option
        (lose initial-offset-option))))
-
+\f
 (define (check-for-illegal-untagged predicate-option print-procedure-option)
   (let ((test
         (lambda (option)
@@ -234,6 +233,23 @@ differences:
     (test predicate-option)
     (test print-procedure-option)))
 
+(define (check-for-illegal-no-descriptor type-descriptor-option
+                                        tagged?
+                                        safe-accessors-option
+                                        keyword-constructor-options)
+  (if tagged?
+      (error "Structure option illegal for tagged structure:"
+            (option/original type-descriptor-option))
+      (let ((lose
+            (lambda (option)
+              (error "Structure option illegal without type descriptor:"
+                     (option/original option)))))
+       (cond ((and safe-accessors-option
+                   (option/argument safe-accessors-option))
+              (lose safe-accessors-option))
+             (keyword-constructor-options
+              (lose (car keyword-constructor-options)))))))
+
 (define (compute-constructors constructor-options
                              keyword-constructor-options
                              context)
@@ -246,16 +262,15 @@ differences:
          (else (list (list (default-constructor-name context)))))))
 
 (define (compute-tagging-info type-descriptor-option named-option context)
-  (let ((single (lambda (name) (values name name))))
-    (cond (type-descriptor-option
-          (single (option/argument type-descriptor-option)))
-         (named-option
-          (let ((arguments (option/arguments named-option)))
-            (if (pair? arguments)
-                (values #f (car arguments))
-                (single (default-type-name context)))))
-         (else
-          (single (default-type-name context))))))
+  (let ((type-name
+        (if type-descriptor-option
+            (option/argument type-descriptor-option)
+            (default-type-name context))))
+    (values type-name
+           (or (and named-option
+                    (pair? (option/arguments named-option))
+                    (option/argument named-option))
+               type-name))))
 \f
 (define (false-expression? object context)
   (or (let loop ((object object))
@@ -305,7 +320,7 @@ differences:
     #F))
 
 (define (default-type-name context)
-  (parser-context/name context))
+  (symbol-append 'RTD: (parser-context/name context)))
 \f
 (define (apply-option-transformers options context)
   (let loop ((options options))
@@ -451,7 +466,7 @@ differences:
     context
     (one-required-argument option
       (lambda (arg)
-       (if (identifier? arg)
+       (if (or (identifier? arg) (not arg))
            `(TYPE-DESCRIPTOR ,arg)
            #f)))))
 
@@ -550,8 +565,9 @@ differences:
 
 (define-record-type <structure>
     (make-structure context conc-name constructors keyword-constructors copier
-                   predicate print-procedure type named? type-descriptor
-                   tag-expression safe-accessors? offset slots)
+                   predicate print-procedure physical-type named?
+                   type-descriptor tag-expression safe-accessors? offset
+                   slots)
     structure?
   (context structure/context)
   (conc-name structure/conc-name)
@@ -560,7 +576,7 @@ differences:
   (copier structure/copier)
   (predicate structure/predicate)
   (print-procedure structure/print-procedure)
-  (type structure/type)
+  (physical-type structure/physical-type)
   (named? structure/tagged?)
   (type-descriptor structure/type-descriptor)
   (tag-expression structure/tag-expression)
@@ -614,18 +630,15 @@ differences:
                         name))))
             (if (structure/safe-accessors? structure)
                 `(DEFINE ,accessor-name
-                   (,(absolute (case (structure/type structure)
+                   (,(absolute (case (structure/physical-type structure)
                                  ((RECORD) 'RECORD-ACCESSOR)
                                  ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-ACCESSOR)
                                  ((LIST) 'DEFINE-STRUCTURE/LIST-ACCESSOR))
                                context)
-                    ,(let ((tag (structure/tag-expression structure)))
-                       (if tag
-                           (close tag context)
-                           (slot/index slot)))
+                    ,(close (structure/type-descriptor structure) context)
                     ',name))
                 `(DEFINE-INTEGRABLE (,accessor-name STRUCTURE)
-                   (,(absolute (case (structure/type structure)
+                   (,(absolute (case (structure/physical-type structure)
                                  ((RECORD) '%RECORD-REF)
                                  ((VECTOR) 'VECTOR-REF)
                                  ((LIST) 'LIST-REF))
@@ -645,18 +658,15 @@ differences:
                         (symbol-append 'SET- name '!)))))
             (if (structure/safe-accessors? structure)
                 `(DEFINE ,modifier-name
-                   (,(absolute (case (structure/type structure)
+                   (,(absolute (case (structure/physical-type structure)
                                  ((RECORD) 'RECORD-MODIFIER)
                                  ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-MODIFIER)
                                  ((LIST) 'DEFINE-STRUCTURE/LIST-MODIFIER))
                                context)
-                    ,(let ((tag (structure/tag-expression structure)))
-                       (if tag
-                           (close tag context)
-                           (slot/index slot)))
+                    ,(close (structure/type-descriptor structure) context)
                     ',name))
                 `(DEFINE-INTEGRABLE (,modifier-name STRUCTURE VALUE)
-                   ,(case (structure/type structure)
+                   ,(case (structure/physical-type structure)
                       ((RECORD)
                        `(,(absolute '%RECORD-SET! context) STRUCTURE
                                                            ,(slot/index slot)
@@ -688,7 +698,7 @@ differences:
   (let ((slot-names (map slot/name (structure/slots structure))))
     (make-constructor structure name slot-names
       (lambda (tag-expression)
-       `(,(absolute (case (structure/type structure)
+       `(,(absolute (case (structure/physical-type structure)
                       ((RECORD) '%RECORD)
                       ((VECTOR) 'VECTOR)
                       ((LIST) 'LIST))
@@ -698,28 +708,30 @@ differences:
 
 (define (constructor-definition/keyword structure name)
   (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)))))))))
+    (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/type structure))
+      (let ((type (structure/physical-type structure))
            (context (structure/context structure)))
        `(,(absolute (case type
                       ((RECORD) '%RECORD)
@@ -747,7 +759,7 @@ differences:
                                                   'RECORD-TYPE-DEFAULT-VALUE
                                                   context)
                                                 ,(close
-                                                  (structure/tag-expression
+                                                  (structure/type-descriptor
                                                    structure)
                                                   context)
                                                 ',name))
@@ -767,9 +779,10 @@ differences:
                         (structure/slots structure)))))))))))
 
 (define (make-constructor structure name lambda-list generate-body)
-  (let* ((context (structure/context structure))
-        (tag-expression (close (structure/tag-expression structure) context)))
-    (if (eq? (structure/type structure) 'RECORD)
+  (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)))
@@ -788,7 +801,7 @@ differences:
   (let ((copier-name (structure/copier structure)))
     (if copier-name
        `((DEFINE ,copier-name
-           ,(absolute (case (structure/type structure)
+           ,(absolute (case (structure/physical-type structure)
                         ((RECORD) 'COPY-RECORD)
                         ((VECTOR) 'VECTOR-COPY)
                         ((LIST) 'LIST-COPY))
@@ -801,7 +814,7 @@ differences:
        (let* ((context (structure/context structure))
               (tag-expression
                (close (structure/tag-expression structure) context)))
-         (case (structure/type structure)
+         (case (structure/physical-type structure)
            ((RECORD)
             `((DEFINE ,predicate-name
                 (LET ((TAG (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
@@ -828,36 +841,44 @@ differences:
        '())))
 
 (define (type-definitions structure)
-  (if (structure/tagged? structure)
-      (let ((type (structure/type structure))
-           (type-name (structure/type-descriptor structure))
-           (slots (structure/slots structure))
-           (context (structure/context structure))
-           (print-procedure (structure/print-procedure structure)))
+  (let ((physical-type (structure/physical-type structure))
+       (type-name (structure/type-descriptor structure))
+       (tag-expression (structure/tag-expression structure))
+       (slots (structure/slots structure))
+       (context (structure/context structure))
+       (print-procedure (structure/print-procedure structure)))
+    (if type-name
        (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
+         `((DEFINE ,type-name
+             ,(if (eq? physical-type 'RECORD)
+                  `(,(absolute 'MAKE-RECORD-TYPE context)
+                    ',name
+                    ',field-names
+                    (LIST ,@inits)
+                    ,(close print-procedure context))
+                  `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context)
+                    ',physical-type
+                    ',name
+                    ',field-names
+                    ',(map slot/index (structure/slots structure))
+                    (LIST ,@inits)
+                    ,(if (structure/tagged? structure)
+                         (close print-procedure context)
+                         '#F)
+                    ,(if (and tag-expression
+                              (not (eq? tag-expression type-name)))
+                         (close tag-expression context)
+                         '#F)
+                    ',(structure/offset structure))))
+           ,@(if (and tag-expression
+                      (not (eq? tag-expression type-name)))
+                 `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context)
+                    ,(close tag-expression context)
+                    ,type-name))
+                 '())))
+       '())))
\ No newline at end of file

diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index 78d413a479783e1ff7ae6c709e63e734db320836..e8b776a5cd6bb4e194d6880c84284063a68cfa47 100644 (file)
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: packag.scm,v 14.42 2003/02/14 18:28:33 cph Exp $
+$Id: packag.scm,v 14.43 2003/03/13 03:57:50 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -244,6 +244,7 @@ USA.
 (define package/system-loader load-package-set)
 \f
 (define-structure (package-file (type vector)
+                               (type-descriptor #f)
                                (conc-name package-file/))
   (tag #f read-only #t)
   (version #f read-only #t)
@@ -251,6 +252,7 @@ USA.
   (loads #f read-only #t))
 
 (define-structure (package-description (type vector)
+                                      (type-descriptor #f)
                                       (conc-name package-description/))
   (name #f read-only #t)
   (ancestors #f read-only #t)
@@ -260,6 +262,7 @@ USA.
   (extension? #f read-only #t))
 
 (define-structure (load-description (type vector)
+                                   (type-descriptor #f)
                                    (conc-name load-description/))
   (name #f read-only #t)
   (file-cases #f read-only #t)

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 0cea9ce77c58b03d0634b6fa35f4c0d18cf1295a..35344c74cf668a8b46b1ddb053782cb48daa9a5b 100644 (file)
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.39 2003/03/12 20:41:42 cph Exp $
+$Id: record.scm,v 1.40 2003/03/13 03:58:18 cph Exp $
 
 Copyright 1989,1990,1991,1993,1994,1996 Massachusetts Institute of Technology
 Copyright 1997,2002,2003 Massachusetts Institute of Technology
@@ -465,38 +465,51 @@ USA.
 (define <structure-type>)
 (define make-define-structure-type)
 (define structure-type?)
-(define structure-type/type)
+(define structure-type/physical-type)
 (define structure-type/name)
 (define structure-type/field-names)
 (define structure-type/field-indexes)
 (define structure-type/default-inits)
 (define structure-type/unparser-method)
 (define set-structure-type/unparser-method!)
+(define structure-type/tag)
+(define structure-type/offset)
 
 (define (initialize-structure-type-type!)
   (set! <structure-type>
        (make-record-type "structure-type"
-                         '(TYPE NAME FIELD-NAMES FIELD-INDEXES
-                                DEFAULT-INITS UNPARSER-METHOD)))
+                         '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES
+                                         DEFAULT-INITS UNPARSER-METHOD TAG
+                                         OFFSET)))
   (set! make-define-structure-type
        (let ((constructor (record-constructor <structure-type>)))
-         (lambda (type name field-names field-indexes v1 #!optional v2)
-           (receive (default-inits unparser-method)
-               (if (default-object? v2)
-                   (values #f v1)
-                   (values v1 v2))
-             (constructor type name
+         (lambda (physical-type name field-names field-indexes . rest)
+           (receive (default-inits unparser-method tag offset)
+               (case (length rest)
+                 ((1) (values #f (car rest) physical-type 0))
+                 ((2) (values (car rest) (cadr rest) physical-type 0))
+                 ((4) (apply values rest))
+                 (else
+                  (error:wrong-number-of-arguments
+                   'MAKE-DEFINE-STRUCTURE-TYPE
+                   8
+                   (cons* physical-type name field-names field-indexes
+                          rest))))
+             (constructor physical-type
+                          name
                           (list->vector field-names)
                           (list->vector field-indexes)
                           (if default-inits
                               (list->vector default-inits)
                               (make-vector (length field-names)
                                            (lambda () #f)))
-                          unparser-method)))))
+                          unparser-method
+                          tag
+                          offset)))))
   (set! structure-type?
        (record-predicate <structure-type>))
-  (set! structure-type/type
-       (record-accessor <structure-type> 'TYPE))
+  (set! structure-type/physical-type
+       (record-accessor <structure-type> 'PHYSICAL-TYPE))
   (set! structure-type/name
        (record-accessor <structure-type> 'NAME))
   (set! structure-type/field-names
@@ -509,6 +522,10 @@ USA.
        (record-accessor <structure-type> 'UNPARSER-METHOD))
   (set! set-structure-type/unparser-method!
        (record-modifier <structure-type> 'UNPARSER-METHOD))
+  (set! structure-type/tag
+       (record-accessor <structure-type> 'TAG))
+  (set! structure-type/offset
+       (record-accessor <structure-type> 'OFFSET))
   unspecific)
 \f
 (define (structure-tag/unparser-method tag type)
@@ -540,11 +557,11 @@ USA.
 
 (define (tag->structure-type tag type)
   (if (structure-type? tag)
-      (and (eq? (structure-type/type tag) type)
+      (and (eq? (structure-type/physical-type tag) type)
           tag)
       (let ((structure-type (named-structure/get-tag-description tag)))
        (and (structure-type? structure-type)
-            (eq? (structure-type/type structure-type) type)
+            (eq? (structure-type/physical-type structure-type) type)
             structure-type))))
 
 (define (structure-tag/default-value tag type field-name)