Integrate generic procedure mechanism into the runtime system. This

mechanism implements a generic procedure call with good performance,
but does not define an associated class structure as is common in
object-oriented programming systems.  It is, however, sufficiently
general to allow such systems to be implemented on top of it, and even
to share objects between different systems if the systems cooperate
slightly.

Much of the change here is to reorganize the cold-load sequence so
that it is possible to bootstrap the runtime system.

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index f51503ca3ab8e8a963278b004e676a257e2e2008..f0ca3663b78aa2c3a4e076f75fe7c25eed19bf49 100644 (file)
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.29 1995/07/10 21:15:01 adams Exp $
+$Id: defstr.scm,v 14.30 1996/04/24 04:22:19 cph Exp $
 
-Copyright (c) 1988-1995 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -82,8 +82,7 @@ differences:
 
 |#
 \f
-(define (initialize-package!)
-  (set! slot-assoc (association-procedure eq? slot/name))
+(define (initialize-define-structure-macro!)
   (syntax-table-define system-global-syntax-table 'DEFINE-STRUCTURE
     transform/define-structure))
 
@@ -107,12 +106,12 @@ differences:
                  (+ index 1)))
          ((null? slots))
        (set-slot/index! (car slots) index))
-      `(BEGIN ,@(constructor-definitions structure)
+      `(BEGIN ,@(type-definitions structure)
+             ,@(constructor-definitions structure)
              ,@(accessor-definitions structure)
              ,@(modifier-definitions structure)
              ,@(predicate-definitions structure)
-             ,@(copier-definitions structure)
-             ,@(type-definitions structure)))))
+             ,@(copier-definitions structure)))))
 \f
 ;;;; Parse Options
 
@@ -308,7 +307,8 @@ differences:
                                   ((eq? type 'RECORD)
                                    false)
                                   (else
-                                   (make-default-defstruct-unparser-text name))))
+                                   (make-default-defstruct-unparser-text
+                                    name))))
                        type
                        named?
                        (and named? type-name)
@@ -365,81 +365,81 @@ differences:
 \f
 ;;;; Descriptive Structure
 
-(define structure-rtd
-  (make-record-type "structure"
-                   '(NAME
-                     CONC-NAME
-                     KEYWORD-CONSTRUCTORS
-                     BOA-CONSTRUCTORS
-                     COPIER-NAME
-                     PREDICATE-NAME
-                     PRINT-PROCEDURE
-                     TYPE
-                     NAMED?
-                     TYPE-NAME
-                     TAG-EXPRESSION
-                     OFFSET
-                     SLOTS)))
-
-(define make-structure
-  (record-constructor structure-rtd))
-
-(define structure?
-  (record-predicate structure-rtd))
-
-(define structure/name
-  (record-accessor structure-rtd 'NAME))
-
-(define structure/conc-name
-  (record-accessor structure-rtd 'CONC-NAME))
-
-(define structure/keyword-constructors
-  (record-accessor structure-rtd 'KEYWORD-CONSTRUCTORS))
-
-(define structure/boa-constructors
-  (record-accessor structure-rtd 'BOA-CONSTRUCTORS))
-
-(define structure/copier-name
-  (record-accessor structure-rtd 'COPIER-NAME))
-
-(define structure/predicate-name
-  (record-accessor structure-rtd 'PREDICATE-NAME))
-
-(define structure/print-procedure
-  (record-accessor structure-rtd 'PRINT-PROCEDURE))
-
-(define structure/type
-  (record-accessor structure-rtd 'TYPE))
-
-(define structure/named?
-  (record-accessor structure-rtd 'NAMED?))
-
-(define structure/type-name
-  (record-accessor structure-rtd 'TYPE-NAME))
-
-(define structure/tag-expression
-  (record-accessor structure-rtd 'TAG-EXPRESSION))
-
-(define structure/offset
-  (record-accessor structure-rtd 'OFFSET))
-
-(define structure/slots
-  (record-accessor structure-rtd 'SLOTS))
-
-(define slot-rtd
-  (make-record-type "slot" '(NAME DEFAULT TYPE READ-ONLY? INDEX)))
-
-(define make-slot
-  (record-constructor slot-rtd '(NAME DEFAULT TYPE READ-ONLY?)))
-
-(define slot/name (record-accessor slot-rtd 'NAME))
-(define slot/default (record-accessor slot-rtd 'DEFAULT))
-(define slot/type (record-accessor slot-rtd 'TYPE))
-(define slot/read-only? (record-accessor slot-rtd 'READ-ONLY?))
-(define slot/index (record-accessor slot-rtd 'INDEX))
-(define set-slot/index! (record-modifier slot-rtd 'INDEX))
-
+(define structure-rtd)
+(define make-structure)
+(define structure?)
+(define structure/name)
+(define structure/conc-name)
+(define structure/keyword-constructors)
+(define structure/boa-constructors)
+(define structure/copier-name)
+(define structure/predicate-name)
+(define structure/print-procedure)
+(define structure/type)
+(define structure/named?)
+(define structure/type-name)
+(define structure/tag-expression)
+(define structure/offset)
+(define structure/slots)
+
+(define slot-rtd)
+(define make-slot)
+(define slot/name)
+(define slot/default)
+(define slot/type)
+(define slot/read-only?)
+(define slot/index)
+(define set-slot/index!)
 (define slot-assoc)
+
+(define (initialize-structure-types!)
+  (set! structure-rtd
+       (make-record-type "structure"
+                         '(NAME
+                           CONC-NAME
+                           KEYWORD-CONSTRUCTORS
+                           BOA-CONSTRUCTORS
+                           COPIER-NAME
+                           PREDICATE-NAME
+                           PRINT-PROCEDURE
+                           TYPE
+                           NAMED?
+                           TYPE-NAME
+                           TAG-EXPRESSION
+                           OFFSET
+                           SLOTS)))
+  (set! make-structure (record-constructor structure-rtd))
+  (set! structure? (record-predicate structure-rtd))
+  (set! structure/name (record-accessor structure-rtd 'NAME))
+  (set! structure/conc-name (record-accessor structure-rtd 'CONC-NAME))
+  (set! structure/keyword-constructors
+       (record-accessor structure-rtd 'KEYWORD-CONSTRUCTORS))
+  (set! structure/boa-constructors
+       (record-accessor structure-rtd 'BOA-CONSTRUCTORS))
+  (set! structure/copier-name (record-accessor structure-rtd 'COPIER-NAME))
+  (set! structure/predicate-name
+       (record-accessor structure-rtd 'PREDICATE-NAME))
+  (set! structure/print-procedure
+       (record-accessor structure-rtd 'PRINT-PROCEDURE))
+  (set! structure/type (record-accessor structure-rtd 'TYPE))
+  (set! structure/named? (record-accessor structure-rtd 'NAMED?))
+  (set! structure/type-name (record-accessor structure-rtd 'TYPE-NAME))
+  (set! structure/tag-expression
+       (record-accessor structure-rtd 'TAG-EXPRESSION))
+  (set! structure/offset (record-accessor structure-rtd 'OFFSET))
+  (set! structure/slots (record-accessor structure-rtd 'SLOTS))
+  (set! slot-rtd
+       (make-record-type "slot" '(NAME DEFAULT TYPE READ-ONLY? INDEX)))
+  (set! make-slot
+       (record-constructor slot-rtd '(NAME DEFAULT TYPE READ-ONLY?)))
+  (set! slot/name (record-accessor slot-rtd 'NAME))
+  (set! slot/default (record-accessor slot-rtd 'DEFAULT))
+  (set! slot/type (record-accessor slot-rtd 'TYPE))
+  (set! slot/read-only? (record-accessor slot-rtd 'READ-ONLY?))
+  (set! slot/index (record-accessor slot-rtd 'INDEX))
+  (set! set-slot/index! (record-modifier slot-rtd 'INDEX))
+  (set! slot-assoc (association-procedure eq? slot/name))
+  (initialize-structure-type-type!))
 \f
 ;;;; Code Generation
 
@@ -511,20 +511,22 @@ differences:
         (map (lambda (slot)
                (string->uninterned-symbol (symbol->string (slot/name slot))))
              (structure/slots structure))))
-    `(DEFINE (,name ,@slot-names)
-       (,(absolute
-         (case (structure/type structure)
-           ((RECORD) '%RECORD)
-           ((VECTOR) 'VECTOR)
-           ((LIST) 'LIST)))
-       ,@(constructor-prefix-slots structure)
-       ,@slot-names))))
+    (make-constructor structure name slot-names
+      (lambda (tag-expression)
+       `(,(absolute
+           (case (structure/type structure)
+             ((RECORD) '%RECORD)
+             ((VECTOR) 'VECTOR)
+             ((LIST) 'LIST)))
+         ,@(constructor-prefix-slots structure tag-expression)
+         ,@slot-names)))))
 
 (define (constructor-definition/keyword structure name)
   (let ((keyword-list (string->uninterned-symbol "keyword-list")))
-    `(DEFINE (,name . ,keyword-list)
-       ,(let ((list-cons
-              `(,@(constructor-prefix-slots structure)
+    (make-constructor structure name keyword-list
+      (lambda (tag-expression)
+       (let ((list-cons
+              `(,@(constructor-prefix-slots structure tag-expression)
                 (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER)
                  ,keyword-list
                  (,(absolute 'LIST)
@@ -538,7 +540,7 @@ differences:
            ((VECTOR)
             `(,(absolute 'APPLY) ,(absolute 'VECTOR) ,@list-cons))
            ((LIST)
-            `(,(absolute 'CONS*) ,@list-cons)))))))
+            `(,(absolute 'CONS*) ,@list-cons))))))))
 
 (define (define-structure/keyword-parser argument-list default-alist)
   (if (null? argument-list)
@@ -559,38 +561,50 @@ differences:
        (map cdr alist))))
 \f
 (define (constructor-definition/boa structure name lambda-list)
-  `(DEFINE (,name . ,lambda-list)
-     (,(absolute
-       (case (structure/type structure)
-         ((RECORD) '%RECORD)
-         ((VECTOR) 'VECTOR)
-         ((LIST) 'LIST)))
-      ,@(constructor-prefix-slots structure)
-      ,@(parse-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))
-                                  ,(slot/default slot)
-                                  ,(slot/name slot)))
-                            (else
-                             (slot/default slot))))
-                    (structure/slots structure)))))))))
-
-(define (constructor-prefix-slots structure)
+  (make-constructor structure name lambda-list
+    (lambda (tag-expression)
+      `(,(absolute
+         (case (structure/type structure)
+           ((RECORD) '%RECORD)
+           ((VECTOR) 'VECTOR)
+           ((LIST) 'LIST)))
+       ,@(constructor-prefix-slots structure tag-expression)
+       ,@(parse-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))
+                                    ,(slot/default slot)
+                                    ,(slot/name slot)))
+                              (else
+                               (slot/default slot))))
+                      (structure/slots structure))))))))))
+
+(define (make-constructor structure name arguments generate-body)
+  (let ((tag-expression (structure/tag-expression structure)))
+    (if (eq? (structure/type structure) 'RECORD)
+       (let ((tag (generate-uninterned-symbol 'TAG-)))
+         `(DEFINE ,name
+            (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
+              (NAMED-LAMBDA (,name ,@arguments)
+                ,(generate-body tag)))))
+       `(DEFINE (,name ,@arguments)
+          ,(generate-body tag-expression)))))
+
+(define (constructor-prefix-slots structure tag-expression)
   (let ((offsets (make-list (structure/offset structure) false)))
     (if (structure/named? structure)
-       (cons (structure/tag-expression structure) offsets)
+       (cons tag-expression offsets)
        offsets)))
 \f
 (define (copier-definitions structure)
@@ -609,24 +623,29 @@ differences:
     (if predicate-name
        (let ((tag-expression (structure/tag-expression structure))
              (variable (string->uninterned-symbol "object")))
-         `((DEFINE (,predicate-name ,variable)
-             ,(case (structure/type structure)
-                ((RECORD)
-                 `(AND (,(absolute '%RECORD?) ,variable)
-                       (,(absolute 'EQ?)
-                        (,(absolute '%RECORD-REF) ,variable 0)
-                        ,tag-expression)))
-                ((VECTOR)
-                 `(AND (,(absolute 'VECTOR?) ,variable)
-                       (,(absolute 'NOT)
-                        (,(absolute 'ZERO?)
-                         (,(absolute 'VECTOR-LENGTH) ,variable)))
-                       (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0)
-                                         ,tag-expression)))
-                ((LIST)
-                 `(AND (,(absolute 'PAIR?) ,variable)
-                       (,(absolute 'EQ?) (,(absolute 'CAR) ,variable)
-                                         ,tag-expression)))))))
+         (case (structure/type structure)
+           ((RECORD)
+            (let ((tag (generate-uninterned-symbol 'TAG-)))
+              `((DEFINE ,predicate-name
+                  (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
+                    (NAMED-LAMBDA (,predicate-name ,variable)
+                      (AND (,(absolute '%RECORD?) ,variable)
+                           (,(absolute 'EQ?)
+                            (,(absolute '%RECORD-REF) ,variable 0)
+                            ,tag))))))))
+           ((VECTOR)
+            `((DEFINE (,predicate-name ,variable)
+                (AND (,(absolute 'VECTOR?) ,variable)
+                     (,(absolute 'NOT)
+                      (,(absolute 'ZERO?)
+                       (,(absolute 'VECTOR-LENGTH) ,variable)))
+                     (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0)
+                                       ,tag-expression)))))
+           ((LIST)
+            `((DEFINE (,predicate-name ,variable)
+                (AND (,(absolute 'PAIR?) ,variable)
+                     (,(absolute 'EQ?) (,(absolute 'CAR) ,variable)
+                                       ,tag-expression)))))))
        '())))
 
 (define (type-definitions structure)
@@ -659,33 +678,38 @@ differences:
                       ,type-expression)))))))
       '()))
 \f
-(define structure-type-rtd
-  (make-record-type "structure-type"
-                   '(TYPE NAME FIELD-NAMES FIELD-INDEXES UNPARSER-METHOD)))
-
-(define make-define-structure-type
-  (record-constructor structure-type-rtd))
-
-(define structure-type?
-  (record-predicate structure-type-rtd))
-
-(define structure-type/type
-  (record-accessor structure-type-rtd 'TYPE))
-
-(define structure-type/name
-  (record-accessor structure-type-rtd 'NAME))
-
-(define structure-type/field-names
-  (record-accessor structure-type-rtd 'FIELD-NAMES))
-
-(define structure-type/field-indexes
-  (record-accessor structure-type-rtd 'FIELD-INDEXES))
-
-(define structure-type/unparser-method
-  (record-accessor structure-type-rtd 'UNPARSER-METHOD))
-
-(define set-structure-type/unparser-method!
-  (record-modifier structure-type-rtd 'UNPARSER-METHOD))
+(define structure-type-rtd)
+(define make-define-structure-type)
+(define structure-type?)
+(define structure-type/type)
+(define structure-type/name)
+(define structure-type/field-names)
+(define structure-type/field-indexes)
+(define structure-type/unparser-method)
+(define set-structure-type/unparser-method!)
+
+(define (initialize-structure-type-type!)
+  (set! structure-type-rtd
+       (make-record-type "structure-type"
+                         '(TYPE NAME FIELD-NAMES FIELD-INDEXES
+                                UNPARSER-METHOD)))
+  (set! make-define-structure-type
+       (record-constructor structure-type-rtd))
+  (set! structure-type?
+       (record-predicate structure-type-rtd))
+  (set! structure-type/type
+       (record-accessor structure-type-rtd 'TYPE))
+  (set! structure-type/name
+       (record-accessor structure-type-rtd 'NAME))
+  (set! structure-type/field-names
+       (record-accessor structure-type-rtd 'FIELD-NAMES))
+  (set! structure-type/field-indexes
+       (record-accessor structure-type-rtd 'FIELD-INDEXES))
+  (set! structure-type/unparser-method
+       (record-accessor structure-type-rtd 'UNPARSER-METHOD))
+  (set! set-structure-type/unparser-method!
+       (record-modifier structure-type-rtd 'UNPARSER-METHOD))
+  unspecific)
 
 (define (structure-tag/unparser-method tag type)
   (let ((structure-type (tag->structure-type tag type)))

diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm
index b0ce5a61665934275e05b9d48b38b95eb3f5bd2b..ac70fe01c792f9fc23eb1606e9f6494fc48c00e2 100644 (file)
--- a/v7/src/runtime/ed-ffi.scm
+++ b/v7/src/runtime/ed-ffi.scm
@@ -1,8 +1,8 @@
 #| -*- Scheme -*-
 
-$Id: ed-ffi.scm,v 1.15 1996/04/24 03:52:10 cph Exp $
+$Id: ed-ffi.scm,v 1.16 1996/04/24 04:27:22 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -114,10 +114,20 @@ MIT in each case. |#
                syntax-table/system-internal)
     ("gdbm"    (runtime gdbm)
                syntax-table/system-internal)
+    ("gencache"        (runtime generic-procedure)
+               syntax-table/system-internal)
+    ("geneqht" (runtime generic-procedure)
+               syntax-table/system-internal)
+    ("generic" (runtime generic-procedure)
+               syntax-table/system-internal)
     ("genio"   (runtime generic-i/o-port)
                syntax-table/system-internal)
+    ("genmult" (runtime generic-procedure multiplexer)
+               syntax-table/system-internal)
     ("gensym"  (runtime gensym)
                syntax-table/system-internal)
+    ("gentag"  (runtime generic-procedure)
+               syntax-table/system-internal)
     ("global"  ()
                syntax-table/system-internal)
     ("graphics"        (runtime graphics)
@@ -210,6 +220,8 @@ MIT in each case. |#
                syntax-table/system-internal)
     ("record"  (runtime record)
                syntax-table/system-internal)
+    ("recslot" (runtime record-slot-access)
+               syntax-table/system-internal)
     ("rep"     (runtime rep)
                syntax-table/system-internal)
     ("savres"  (runtime save/restore)
@@ -256,6 +268,8 @@ MIT in each case. |#
                syntax-table/system-internal)
     ("ttyio"   (runtime console-i/o-port)
                syntax-table/system-internal)
+    ("tvector" (runtime tagged-vector)
+               syntax-table/system-internal)
     ("udata"   ()
                syntax-table/system-internal)
     ("uenvir"  (runtime environment)

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 21b93cce7843f3ae1d9c52a5ed852e5d284bab6a..7728f6a01c36f981d687159484e8a4438dbd9d19 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.57 1995/04/13 22:24:53 cph Exp $
+$Id: make.scm,v 14.58 1996/04/24 04:23:54 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -342,11 +342,14 @@ MIT in each case. |#
         ("list" . (RUNTIME LIST))
         ("symbol" . ())
         ("uproc" . (RUNTIME PROCEDURE))
+        ("fixart" . ())
+        ("random" . (RUNTIME RANDOM-NUMBER))
+        ("gentag" . (RUNTIME GENERIC-PROCEDURE))
         ("poplat" . (RUNTIME POPULATION))
-        ("record" . (RUNTIME RECORD))))
+        ("record" . (RUNTIME RECORD))
+        ("defstr" . (RUNTIME DEFSTRUCT))))
       (files2
-       '(("defstr" . (RUNTIME DEFSTRUCT))
-        ("prop1d" . (RUNTIME 1D-PROPERTY))
+       '(("prop1d" . (RUNTIME 1D-PROPERTY))
         ("events" . (RUNTIME EVENT-DISTRIBUTOR))
         ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
       (load-files
@@ -362,9 +365,12 @@ MIT in each case. |#
                      'CONSTANT-SPACE/BASE
                      constant-space/base)
   (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME RANDOM-NUMBER) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS!
+                     #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true)
+  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
+  (package-initialize '(RUNTIME DEFSTRUCT) 'INITIALIZE-STRUCTURE-TYPES! #t)
   (load-files files2)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
@@ -399,7 +405,6 @@ MIT in each case. |#
    ;; Microcode interface
    ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES! #t)
    (RUNTIME STATE-SPACE)
-   (RUNTIME MICROCODE-TABLES)
    (RUNTIME APPLY)
    (RUNTIME HASH)                      ; First GC daemon!
    (RUNTIME PRIMITIVE-IO)
@@ -412,7 +417,6 @@ MIT in each case. |#
    (RUNTIME GENSYM)
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
-   (RUNTIME RANDOM-NUMBER)
    ;; Microcode data structures
    (RUNTIME HISTORY)
    (RUNTIME LAMBDA-ABSTRACTION)
@@ -421,9 +425,20 @@ MIT in each case. |#
    (RUNTIME SCODE-WALKER)
    (RUNTIME CONTINUATION-PARSER)
    (RUNTIME PROGRAM-COPIER)
+   ;; Generic Procedures
+   ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING! #t)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER! #t)
+   ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR! #t)
+   ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS! #t)
+   ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES! #t)
+   ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE! #t)
+   ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE! #t)
    ;; Condition System
    (RUNTIME ERROR-HANDLER)
    (RUNTIME MICROCODE-ERRORS)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads
@@ -450,7 +465,7 @@ MIT in each case. |#
    (RUNTIME ILLEGAL-DEFINITIONS)
    (RUNTIME MACROS)
    (RUNTIME SYSTEM-MACROS)
-   (RUNTIME DEFSTRUCT)
+   ((RUNTIME DEFSTRUCT) INITIALIZE-DEFINE-STRUCTURE-MACRO! #t)
    (RUNTIME UNSYNTAXER)
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)

diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index ab6f3ead8c162f08a8b5cbe18153be46b46a688e..1dadbcbf60e70ba6c8db9d2cbec16707745086cc 100644 (file)
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: packag.scm,v 14.24 1995/11/01 01:05:28 cph Exp $
+$Id: packag.scm,v 14.25 1996/04/24 04:22:46 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -43,15 +43,14 @@ MIT in each case. |#
 ;;; record type, then build the record type and clobber it into the
 ;;; packages.  Thereafter, packages are constructed normally.
 
-(define package-rtd
-  false)
+(define package-tag #f)
 
 (define-integrable (make-package parent name environment)
-  (%record package-rtd parent '() name environment))
+  (%record package-tag parent '() name environment))
 
 (define (package? object)
   (and (%record? object)
-       (eq? (%record-ref object 0) package-rtd)))
+       (eq? (%record-ref object 0) package-tag)))
 
 (define-integrable (package/parent package)
   (%record-ref package 1))
@@ -74,16 +73,16 @@ MIT in each case. |#
 (define (finalize-package-record-type!)
   (let ((rtd
         (make-record-type "package" '(PARENT CHILDREN %NAME ENVIRONMENT))))
-    (set! package-rtd rtd)
-    (let loop ((package system-global-package))
-      (%record-set! package 0 rtd)
-      (for-each loop (package/children package)))
-    (set-record-type-unparser-method!
-     rtd
-     (standard-unparser-method 'PACKAGE
-       (lambda (package port)
-        (write-char #\space port)
-        (write (package/name package) port))))))
+    (let ((tag (record-type-dispatch-tag rtd)))
+      (set! package-tag tag)
+      (let loop ((package system-global-package))
+       (%record-set! package 0 tag)
+       (for-each loop (package/children package))))
+    (set-record-type-unparser-method! rtd
+      (standard-unparser-method 'PACKAGE
+       (lambda (package port)
+         (write-char #\space port)
+         (write (package/name package) port))))))
 \f
 (define (package/child package name)
   (let loop ((children (package/children package)))

diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm
index 2c8eba137f4a705b8a89dace11983c0c2d539129..e0107888bb9f4b1c91b652613b7f3ced93264efa 100644 (file)
--- a/v7/src/runtime/pp.scm
+++ b/v7/src/runtime/pp.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: pp.scm,v 14.36 1995/08/06 15:53:07 adams Exp $
+$Id: pp.scm,v 14.37 1996/04/24 04:22:59 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -38,6 +38,11 @@ MIT in each case. |#
 (declare (usual-integrations))
 \f
 (define (initialize-package!)
+  (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION))
+  (set-generic-procedure-default-generator! pp-description
+    (lambda (generic tags)
+      generic tags
+      pp-description/default))
   (set! forced-indentation (special-printer kernel/forced-indentation))
   (set! pressured-indentation (special-printer kernel/pressured-indentation))
   (set! print-procedure (special-printer kernel/print-procedure))
@@ -59,7 +64,6 @@ MIT in each case. |#
   (set! dispatch-list code-dispatch-list)
   (set! dispatch-default print-combination)
   (set! cocked-object (generate-uninterned-symbol))
-  (set! hook/pp-description #f)
   unspecific)
 
 (define *pp-named-lambda->define?* false)
@@ -90,25 +94,24 @@ MIT in each case. |#
            (else
             (pretty-print object))))))
 
-(define (pp-description object)
-  (cond ((and hook/pp-description
-             (hook/pp-description object)))
-       ((named-structure? object)
+(define pp-description)
+
+(define (pp-description/default object)
+  (cond ((named-structure? object)
         (named-structure/description object))
        ((%record? object)              ; unnamed record
         (let loop ((i (- (%record-length object) 1)) (d '()))
           (if (< i 0)
               d
-              (loop (- i 1) (cons (list i (%record-ref object i)) d)))))
+              (loop (- i 1)
+                    (cons (list i (%record-ref object i)) d)))))
        ((weak-pair? object)
-        `((weak-car ,(weak-car object))
-          (weak-cdr ,(weak-cdr object))))
+        `((WEAK-CAR ,(weak-car object))
+          (WEAK-CDR ,(weak-cdr object))))
        ((cell? object)
-        `((contents ,(cell-contents object))))
+        `((CONTENTS ,(cell-contents object))))
        (else
         #f)))
-
-(define hook/pp-description)
 \f
 ;;; Controls the appearance of procedures in the CASE statement used
 ;;; to describe an arity dispatched procedure:

diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm
index 47831f926cedff57a80fb0ba974d984cb812442c..e2a4d543eb464415d98c69122cbac2ef02e2c037 100644 (file)
--- a/v7/src/runtime/random.scm
+++ b/v7/src/runtime/random.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: random.scm,v 14.13 1995/08/02 03:56:44 adams Exp $
+$Id: random.scm,v 14.14 1996/04/24 04:18:18 cph Exp $
 
 Copyright (c) 1993-95 Massachusetts Institute of Technology
 
@@ -59,20 +59,20 @@ MIT in each case. |#
 (define-integrable b. 4294967291. #|(exact->inexact b)|#)
 
 (define (random modulus #!optional state)
-  (if (not (and (real? modulus) (< 0 modulus)))
-      (error:wrong-type-argument modulus "positive real" 'RANDOM))
   (let ((element
         (flo:random-unit
          (guarantee-random-state (if (default-object? state) #f state)
                                  'RANDOM))))
     ;; Kludge: an exact integer modulus means that result is an exact
     ;; integer.  Otherwise, the result is a real number.
-    (cond ((flo:flonum? modulus)
+    (cond ((and (flo:flonum? modulus) (flo:< 0. modulus))
           (flo:* element modulus))
-         ((exact-integer? modulus)
+         ((and (int:integer? modulus) (int:< 0 modulus))
           (flo:truncate->exact (flo:* element (int:->flonum modulus))))
+         ((and (real? modulus) (< 0 modulus))
+          (* (inexact->exact element) modulus))
          (else
-          (* (inexact->exact element) modulus)))))
+          (error:wrong-type-argument modulus "positive real" 'RANDOM)))))
 
 (define (flo:random-unit state)
   (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
@@ -102,7 +102,7 @@ MIT in each case. |#
 
 (define (make-random-state #!optional state)
   (let ((state (if (default-object? state) #f state)))
-    (if (or (eq? #t state) (exact-integer? state))
+    (if (or (eq? #t state) (int:integer? state))
        (initial-random-state
         (congruential-rng (+ (real-time-clock) 123456789)))
        (copy-random-state
@@ -118,7 +118,7 @@ MIT in each case. |#
     (let fill ()
       (do ((i 0 (fix:+ i 1)))
          ((fix:= i r))
-       (flo:vector-set! seeds i (exact->inexact (generate-random-seed b))))
+       (flo:vector-set! seeds i (int:->flonum (generate-random-seed b))))
       ;; Disallow cases with all seeds either 0 or b-1, since they can
       ;; get locked in trivial cycles.
       (if (or (let loop ((i 0))
@@ -137,20 +137,34 @@ MIT in each case. |#
   (let ((a 16807 #|(expt 7 5)|#)
        (m 2147483647 #|(- (expt 2 31) 1)|#))
     (let ((m-1 (- m 1)))
-      (let ((seed (+ (modulo seed m-1) 1)))
+      (let ((seed (+ (int:remainder seed m-1) 1)))
        (lambda (b)
-         (let ((n (modulo (* a seed) m)))
+         (let ((n (int:remainder (* a seed) m)))
            (set! seed n)
-           (quotient (* (- n 1) b) m-1)))))))
+           (int:quotient (* (- n 1) b) m-1)))))))
+\f
+;;; The RANDOM-STATE data abstraction must be built by hand because
+;;; the random-number generator is needed in order to build the record
+;;; abstraction.
+
+(define-integrable (%make-random-state i b v)
+  (vector random-state-tag i b v))
+
+(define (random-state? object)
+  (and (vector? object)
+       (not (fix:= (vector-length object) 0))
+       (eq? (vector-ref object 0) random-state-tag)))
+
+(define random-state-tag
+  ((ucode-primitive string->symbol) "#[(runtime random-number)random-state]"))
+
+(define-integrable (random-state-index s) (vector-ref s 1))
+(define-integrable (set-random-state-index! s x) (vector-set! s 1 x))
+
+(define-integrable (random-state-borrow s) (vector-ref s 2))
+(define-integrable (set-random-state-borrow! s x) (vector-set! s 2 x))
 
-(define-structure (random-state
-                  (type vector)
-                  (named ((ucode-primitive string->symbol)
-                          "#[(runtime random-number)random-state]"))
-                  (constructor %make-random-state))
-  index
-  borrow
-  vector)
+(define-integrable (random-state-vector s) (vector-ref s 3))
 
 (define (copy-random-state state)
   (%make-random-state (random-state-index state)
@@ -180,4 +194,12 @@ MIT in each case. |#
 
 (define (initialize-package!)
   (set! *random-state* (make-random-state #t))
-  unspecific)
\ No newline at end of file
+  unspecific)
+
+(define (finalize-random-state-type!)
+  (named-structure/set-tag-description! random-state-tag
+    (make-define-structure-type 'VECTOR
+                               'RECORD-STATE
+                               '(INDEX BORROW VECTOR)
+                               '(1 2 3)
+                               #f)))
\ No newline at end of file

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 5bf3d407b791b44f04e26617cd433e5f77a48f94..daa51b2ac99f90ab2ff6f2a3704e8c602c5fa4f9 100644 (file)
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.23 1994/09/01 22:39:01 adams Exp $
+$Id: record.scm,v 1.24 1996/04/24 04:23:11 cph Exp $
 
-Copyright (c) 1989-1994 Massachusetts Institute of Technology
+Copyright (c) 1989-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -49,30 +49,6 @@ MIT in each case. |#
   (primitive-object-set! 3)
   (primitive-object-set-type 2))
 
-(define record-type-type)
-(define record-type-population)
-(define record-type-initialization-hook)
-
-(define (initialize-package!)
-  (set! record-type-type
-       (let ((record-type-type
-              (%record false
-                       false
-                       "record-type"
-                       '(RECORD-TYPE-APPLICATION-METHOD
-                         RECORD-TYPE-NAME
-                         RECORD-TYPE-FIELD-NAMES
-                         RECORD-TYPE-METHODS
-                         RECORD-TYPE-CLASS-WRAPPER)
-                       '()
-                       false)))
-         (%record-set! record-type-type 0 record-type-type)
-         (%record-type-has-application-method! record-type-type)
-         record-type-type))
-  (set! record-type-population (make-population))
-  (set! record-type-initialization-hook false)
-  (add-to-population! record-type-population record-type-type))
-
 (define-integrable (%record? object)
   (object-type? (ucode-type record) object))
 
@@ -81,9 +57,10 @@ MIT in each case. |#
       (error:wrong-type-argument length "exact integer" '%MAKE-RECORD))
   (if (not (> length 0))
       (error:bad-range-argument length '%MAKE-RECORD))
-  (if (default-object? object)
-      (object-new-type (ucode-type record) (make-vector length))
-      (object-new-type (ucode-type record) (make-vector length object))))
+  (object-new-type
+   (ucode-type record)
+   ((ucode-primitive vector-cons) length
+                                 (if (default-object? object) #f object))))
 
 (define (%record-copy record)
   (let ((length (%record-length record)))
@@ -96,109 +73,121 @@ MIT in each case. |#
          ((= index length))
        (%record-set! result index (%record-ref record index)))
       result)))
-
-(define (%record-application-method record)
-  ;; This procedure must match the code in "microcode/interp.c".
-  (let ((record-type (%record-ref record 0)))
-    (and (%record? record-type)
-        (and (object-type? (ucode-type constant)
-                           (primitive-object-ref record-type 0))
-             (>= (%record-length record-type) 2))
-        (let ((method (%record-ref record-type 1)))
-          (and (not (eq? method record))
-               method)))))
-
-(define (%record-type-has-application-method! record-type)
-  (primitive-object-set!
-   record-type
-   0
-   (primitive-object-set-type (ucode-type constant)
-                             (primitive-object-ref record-type 0))))
+\f
+(define record-type-type-tag)
+(define unparse-record)
+(define record-description)
+
+(define (initialize-record-type-type!)
+  (let ((type
+        (%record #f
+                 "record-type"
+                 '(RECORD-TYPE-NAME
+                   RECORD-TYPE-FIELD-NAMES
+                   RECORD-TYPE-DISPATCH-TAG)
+                 #f)))
+    (set! record-type-type-tag (make-dispatch-tag type))
+    (%record-set! type 0 record-type-type-tag)
+    (%record-set! type 3 record-type-type-tag)))
+
+(define (initialize-record-procedures!)
+  (set! unparse-record (make-generic-procedure 2 'UNPARSE-RECORD))
+  (set-generic-procedure-default-generator! unparse-record
+    (let ((record-method (standard-unparser-method 'RECORD #f)))
+      (lambda (generic tags)
+       generic
+       (let ((tag (cadr tags)))
+         (cond ((record-type? (dispatch-tag-contents tag))
+                (standard-unparser-method
+                 (record-type-name (dispatch-tag-contents tag))
+                 #f))
+               ((eq? tag record-type-type-tag)
+                (standard-unparser-method 'TYPE
+                  (lambda (type port)
+                    (write-char #\space port)
+                    (display (record-type-name type) port))))
+               ((eq? tag (built-in-dispatch-tag 'DISPATCH-TAG))
+                (standard-unparser-method 'DISPATCH-TAG
+                  (lambda (tag port)
+                    (write-char #\space port)
+                    (write (dispatch-tag-contents tag) port))))
+               (else record-method))))))
+  (set! set-record-type-unparser-method!
+       set-record-type-unparser-method!/after-boot)
+  (for-each (lambda (t.m)
+             (set-record-type-unparser-method! (car t.m) (cdr t.m)))
+           deferred-unparser-methods)
+  (set! deferred-unparser-methods)
+  (set! record-description (make-generic-procedure 1 'RECORD-DESCRIPTION))
+  (set-generic-procedure-default-generator! record-description
+    (lambda (generic tags)
+      generic
+      (if (record-type? (dispatch-tag-contents (car tags)))
+         (lambda (record)
+           (let ((type (record-type-descriptor record)))
+             (map (lambda (field-name)
+                    `(,field-name
+                      ,((record-accessor type field-name) record)))
+                  (record-type-field-names type))))
+         (lambda (record)
+           (let loop ((i (fix:- (%record-length record) 1)) (d '()))
+             (if (fix:< i 0)
+                 d
+                 (loop (fix:- i 1)
+                       (cons (list i (%record-ref record i)) d)))))))))
 \f
 (define (make-record-type type-name field-names #!optional print-method)
   (guarantee-list-of-unique-symbols field-names 'MAKE-RECORD-TYPE)
   (let ((record-type
-        (%record record-type-type
-                 false
+        (%record record-type-type-tag
                  (->string type-name)
                  (list-copy field-names)
-                 '()
-                 false)))
-    (%record-type-has-application-method! record-type)
-    (add-to-population! record-type-population record-type)
-    (if record-type-initialization-hook
-       (record-type-initialization-hook record-type))
+                 #f)))
+    (%record-set! record-type 3 (make-dispatch-tag record-type))
     (if (not (default-object? print-method))
        (set-record-type-unparser-method! record-type print-method))
     record-type))
 
 (define (record-type? object)
   (and (%record? object)
-       (eq? (%record-ref object 0) record-type-type)))
-
-(define (record-type-application-method record-type)
-  (guarantee-record-type record-type 'RECORD-TYPE-APPLICATION-METHOD)
-  (%record-ref record-type 1))
-
-(define (set-record-type-application-method! record-type method)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-APPLICATION-METHOD!)
-  (if (not (or (not method) (procedure? method)))
-      (error:wrong-type-argument method "application method"
-                                'SET-RECORD-TYPE-APPLICATION-METHOD!))
-  (%record-set! record-type 1 method))
+       (eq? (%record-ref object 0) record-type-type-tag)))
 
 (define (record-type-name record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-NAME)
-  (%record-type/name record-type))
-
-(define-integrable (%record-type/name record-type)
-  (%record-ref record-type 2))
+  (%record-ref record-type 1))
 
 (define (record-type-field-names record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES)
-  (list-copy (%record-type/field-names record-type)))
+  (%record-ref record-type 2))
 
-(define-integrable (%record-type/field-names record-type)
+(define (record-type-dispatch-tag record-type)
+  (guarantee-record-type record-type 'RECORD-TYPE-DISPATCH-TAG)
   (%record-ref record-type 3))
 
-(define (record-type-unparser-method record-type)
-  (record-type-method record-type 'UNPARSER))
-
 (define (set-record-type-unparser-method! record-type method)
+  (set! deferred-unparser-methods
+       (cons (cons record-type method) deferred-unparser-methods))
+  unspecific)
+
+(define deferred-unparser-methods '())
+
+(define (set-record-type-unparser-method!/after-boot record-type method)
   (if (not (or (not method) (procedure? method)))
       (error:wrong-type-argument method "unparser method"
                                 'SET-RECORD-TYPE-UNPARSER-METHOD!))
-  (set-record-type-method! record-type 'UNPARSER method))
-
-(define (record-type-method record-type keyword)
-  (guarantee-record-type record-type 'RECORD-TYPE-METHOD)
-  (let ((entry (assq keyword (%record-ref record-type 4))))
-    (and entry
-        (cdr entry))))
-
-(define (set-record-type-method! record-type keyword method)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-METHOD!)
-  (let ((methods (%record-ref record-type 4)))
-    (let ((entry (assq keyword methods)))
-      (if method
-         (if entry
-             (set-cdr! entry method)
-             (%record-set! record-type 4
-                           (cons (cons keyword method) methods)))
-         (if entry
-             (%record-set! record-type 4 (delq! entry methods)))))))
-
-(define (record-type-field-index record-type field-name procedure-name)
-  (let loop ((field-names (%record-type/field-names record-type)) (index 1))
-    (if (null? field-names)
-       (error:bad-range-argument field-name procedure-name))
-    (if (eq? field-name (car field-names))
-       index
-       (loop (cdr field-names) (+ index 1)))))
+  (remove-generic-procedure-generators
+   unparse-record
+   (list (make-dispatch-tag #f) record-type))
+  (add-generic-procedure-generator unparse-record
+    (lambda (generic tags)
+      generic
+      (and (eq? (cadr tags) (record-type-dispatch-tag record-type))
+          method))))
 \f
 (define (record-constructor record-type #!optional field-names)
   (guarantee-record-type record-type 'RECORD-CONSTRUCTOR)
-  (let ((all-field-names (%record-type/field-names record-type)))
+  (let ((all-field-names (record-type-field-names record-type))
+       (tag (record-type-dispatch-tag record-type)))
     (let ((field-names
           (if (default-object? field-names) all-field-names field-names))
          (record-length (+ 1 (length all-field-names))))
@@ -216,7 +205,7 @@ MIT in each case. |#
          (let ((record
                 (object-new-type (ucode-type record)
                                  (make-vector record-length))))
-           (%record-set! record 0 record-type)
+           (%record-set! record 0 tag)
            (do ((indexes indexes (cdr indexes))
                 (field-values field-values (cdr field-values)))
                ((null? indexes))
@@ -225,51 +214,55 @@ MIT in each case. |#
 
 (define (record? object)
   (and (%record? object)
-       (record-type? (%record-ref object 0))))
+       (dispatch-tag? (%record-ref object 0))
+       (record-type? (dispatch-tag-contents (%record-ref object 0)))))
 
 (define (record-type-descriptor record)
   (guarantee-record record 'RECORD-TYPE-DESCRIPTOR)
-  (%record-ref record 0))
+  (dispatch-tag-contents (%record-ref record 0)))
 
 (define (record-copy record)
   (guarantee-record record 'RECORD-COPY)
   (%record-copy record))
 
-(define (record-description record)
-  (let ((type (record-type-descriptor record)))
-    (let ((method (record-type-method type 'DESCRIPTION)))
-      (if method
-         (method record)
-         (map (lambda (field-name)
-                `(,field-name ,((record-accessor type field-name) record)))
-              (record-type-field-names type))))))
-
 (define (record-predicate record-type)
   (guarantee-record-type record-type 'RECORD-PREDICATE)
-  (lambda (object)
-    (and (%record? object)
-        (eq? (%record-ref object 0) record-type))))
+  (let ((tag (record-type-dispatch-tag record-type)))
+    (lambda (object)
+      (and (%record? object)
+          (eq? (%record-ref object 0) tag)))))
 
 (define (record-accessor record-type field-name)
   (guarantee-record-type record-type 'RECORD-ACCESSOR)
-  (let ((procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
+  (let ((tag (record-type-dispatch-tag record-type))
+       (type-name (record-type-name record-type))
+       (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
        (index
         (record-type-field-index record-type field-name 'RECORD-ACCESSOR)))
     (lambda (record)
-      (guarantee-record-of-type record record-type procedure-name)
+      (guarantee-record-of-type record tag type-name procedure-name)
       (%record-ref record index))))
 
 (define (record-modifier record-type field-name)
   (guarantee-record-type record-type 'RECORD-MODIFIER)
-  (let ((procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
+  (let ((tag (record-type-dispatch-tag record-type))
+       (type-name (record-type-name record-type))
+       (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
        (index
         (record-type-field-index record-type field-name 'RECORD-MODIFIER)))
     (lambda (record field-value)
-      (guarantee-record-of-type record record-type procedure-name)
+      (guarantee-record-of-type record tag type-name procedure-name)
       (%record-set! record index field-value))))
 
 (define record-updater
   record-modifier)
+
+(define (record-type-field-index record-type field-name error-name)
+  (let loop ((field-names (record-type-field-names record-type)) (index 1))
+    (cond ((null? field-names)
+          (and error-name (error:bad-range-argument field-name error-name)))
+         ((eq? field-name (car field-names)) index)
+         (else (loop (cdr field-names) (+ index 1))))))
 \f
 (define (->string object)
   (if (string? object)
@@ -292,13 +285,13 @@ MIT in each case. |#
   (if (not (record-type? record-type))
       (error:wrong-type-argument record-type "record type" procedure)))
 
-(define-integrable (guarantee-record-of-type record record-type procedure-name)
+(define-integrable (guarantee-record-of-type record tag type-name
+                                            procedure-name)
   (if (not (and (%record? record)
-               (eq? (%record-ref record 0) record-type)))
-      (error:wrong-type-argument
-       record
-       (string-append "record of type " (%record-type/name record-type))
-       procedure-name)))
+               (eq? (%record-ref record 0) tag)))
+      (error:wrong-type-argument record
+                                (string-append "record of type " type-name)
+                                procedure-name)))
 
 (define-integrable (guarantee-record record procedure-name)
   (if (not (record? record))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index eaac1ef3d5bb4befe594279059f5599008aceb9c..3fa03546e24d1bccdf0fd267b86f650f7186f19c 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.268 1996/04/24 03:48:50 cph Exp $
+$Id: runtime.pkg,v 14.269 1996/04/24 04:17:28 cph Exp $
 
 Copyright (c) 1988-96 Massachusetts Institute of Technology
 
@@ -762,6 +762,8 @@ MIT in each case. |#
          add-primitive-gc-daemon!)
   (export (runtime hash-table)
          add-primitive-gc-daemon!)
+  (export (runtime generic-procedure eqht)
+         add-primitive-gc-daemon!)
   (export (runtime interrupt-handler)
          trigger-gc-daemons!)
   (initialization (initialize-package!)))
@@ -1634,6 +1636,7 @@ MIT in each case. |#
          *pp-uninterned-symbols-by-name*
          make-pretty-printer-highlight
          pp
+         pp-description
          pretty-print)
   (initialization (initialize-package!)))
 
@@ -1805,12 +1808,10 @@ MIT in each case. |#
   (export ()
          %make-record
          %record
-         %record-application-method
          %record-copy
          %record-length
          %record-ref
          %record-set!
-         %record-type-has-application-method!
          %record?
          make-record-type
          record-accessor
@@ -1819,18 +1820,17 @@ MIT in each case. |#
          record-description
          record-modifier
          record-predicate
-         record-type-application-method
          record-type-descriptor
+         record-type-dispatch-tag
          record-type-field-names
-         record-type-method
          record-type-name
-         record-type-unparser-method
          record-type?
          record-updater
          record?
-         set-record-type-application-method!
-         set-record-type-method!
-         set-record-type-unparser-method!)
+         set-record-type-unparser-method!
+         unparse-record)
+  (export (runtime record-slot-access)
+         record-type-field-index)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)
@@ -3185,4 +3185,115 @@ MIT in each case. |#
          ordered-vector-matches
          ordered-vector-minimum-match
          search-ordered-subvector
-         search-ordered-vector))
\ No newline at end of file
+         search-ordered-vector))
+
+(define-package (runtime gdbm)
+  (file-case options
+    ((load) "gdbm")
+    (else))
+  (parent ())
+  (export ()
+         gdbm-available?
+         gdbm-close
+         gdbm-delete
+         gdbm-exists?
+         gdbm-fetch
+         gdbm-firstkey
+         gdbm-nextkey
+         gdbm-open
+         gdbm-reorganize
+         gdbm-setopt
+         gdbm-store
+         gdbm-sync
+         gdbm-version
+         gdbm_cachesize
+         gdbm_fast
+         gdbm_fastmode
+         gdbm_insert
+         gdbm_newdb
+         gdbm_reader
+         gdbm_replace
+         gdbm_wrcreat
+         gdbm_writer))
+\f
+(define-package (runtime generic-procedure)
+  (files "gentag" "gencache" "generic")
+  (parent ())
+  (export ()
+         ;; tag.scm:
+         dispatch-tag-contents
+         dispatch-tag?
+         guarantee-dispatch-tag
+         make-dispatch-tag
+         set-dispatch-tag-contents!
+
+         ;; generic.scm:
+         arity-max
+         arity-min
+         built-in-dispatch-tag
+         built-in-dispatch-tags
+         condition-type:no-applicable-methods
+         dispatch-tag
+         error:no-applicable-methods
+         generic-procedure-applicable?
+         generic-procedure-arity
+         generic-procedure-name
+         generic-procedure?
+         guarantee-generic-procedure
+         make-generic-procedure
+         purge-generic-procedure-cache
+         standard-generic-procedure-tag)
+  (export (runtime generic-procedure multiplexer)
+         generic-procedure-generator
+         set-generic-procedure-generator!))
+
+(define-package (runtime generic-procedure multiplexer)
+  (files "genmult")
+  (parent ())
+  (export ()
+         add-generic-procedure-generator
+         condition-type:extra-applicable-methods
+         error:extra-applicable-methods
+         generic-procedure-default-generator
+         generic-procedure-generator-list
+         remove-generic-procedure-generator
+         remove-generic-procedure-generators
+         set-generic-procedure-default-generator!))
+
+(define-package (runtime tagged-vector)
+  (files "tvector")
+  (parent ())
+  (export ()
+         guarantee-tagged-vector
+         make-tagged-vector
+         record-slot-uninitialized
+         set-tagged-vector-element!
+         set-tagged-vector-tag!
+         tagged-vector
+         tagged-vector-element
+         tagged-vector-element-initialized?
+         tagged-vector-length
+         tagged-vector-tag
+         tagged-vector?))
+
+(define-package (runtime record-slot-access)
+  (files "recslot")
+  (parent ())
+  (export ()
+         %record-accessor
+         %record-accessor-generator
+         %record-initpred
+         %record-initpred-generator
+         %record-modifier
+         %record-modifier-generator
+         %record-slot-index
+         %record-slot-names))
+
+(define-package (runtime generic-procedure eqht)
+  (files "geneqht")
+  (parent ())
+  (export (runtime generic-procedure)
+         eqht/for-each
+         eqht/get
+         eqht/put!
+         make-eqht))
\ No newline at end of file

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index bfec4fc3c3df6cf226449697b505c949f0fb1a33..962077cb4f99b55f32717c9f488c404ce176e57a 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: unpars.scm,v 14.44 1995/07/27 21:10:31 adams Exp $
+$Id: unpars.scm,v 14.45 1996/04/24 04:17:53 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -41,8 +41,6 @@ MIT in each case. |#
   (set! string-delimiters
        (char-set-union char-set:not-graphic (char-set #\" #\\)))
   (set! hook/interned-symbol unparse-symbol)
-  (set! hook/record-unparser false)
-  (set! hook/unparse-record false)
   (set! hook/procedure-unparser false)
   (set! *unparser-radix* 10)
   (set! *unparser-list-breadth-limit* false)
@@ -320,7 +318,8 @@ MIT in each case. |#
   (cond ((not object) (*unparse-string "#f"))
        ((null? object) (*unparse-string "()"))
        ((eq? object #t) (*unparse-string "#t"))
-       ((undefined-value? object) (*unparse-string "#[unspecified-return-value]"))
+       ((undefined-value? object)
+        (*unparse-string "#[unspecified-return-value]"))
        ((eq? object lambda-auxiliary-tag) (*unparse-string "#!aux"))
        ((eq? object lambda-optional-tag) (*unparse-string "#!optional"))
        ((eq? object lambda-rest-tag) (*unparse-string "#!rest"))
@@ -461,26 +460,9 @@ MIT in each case. |#
   (vector-ref vector index))
 
 (define (unparse/record record)
-  (let ((method
-        (and hook/record-unparser
-             (hook/record-unparser record))))
-    (cond (method
-          (invoke-user-method method record))
-         ((record? record)
-          (let ((type (record-type-descriptor record)))
-            (let ((method
-                   (or (record-type-unparser-method type)
-                       hook/unparse-record)))
-              (if method
-                  (invoke-user-method method record)
-                  (*unparse-with-brackets (record-type-name type)
-                                          record
-                                          #f)))))
-         (else
-          (unparse/default record)))))
-
-(define hook/record-unparser)
-(define hook/unparse-record)
+  (if *unparse-with-maximum-readability?*
+      (*unparse-readable-hash record)
+      (invoke-user-method unparse-record record)))
 \f
 (define (unparse/pair pair)
   (let ((prefix (unparse-list/prefix-pair? pair)))
@@ -569,9 +551,13 @@ MIT in each case. |#
   (let ((method
         (and hook/procedure-unparser
              (hook/procedure-unparser procedure))))
-    (if method
-       (invoke-user-method method procedure)
-       (usual-method))))
+    (cond (method (invoke-user-method method procedure))
+         ((generic-procedure? procedure)
+          (*unparse-with-brackets 'GENERIC-PROCEDURE procedure
+            (let ((name (generic-procedure-name procedure)))
+              (and name
+                   (lambda () (*unparse-object name))))))
+         (else (usual-method)))))
 
 (define (unparse/compound-procedure procedure)
   (unparse-procedure procedure

diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 5cc392accff77ee4928e110dcc506938d2983ecd..a255a0fb866e405344ebd7d6aa2b6e47544bf9a1 100644 (file)
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.8 1995/02/14 01:06:18 cph Exp $
+$Id: uproc.scm,v 1.9 1996/04/24 04:23:19 cph Exp $
 
-Copyright (c) 1990-92 Massachusetts Institute of Technology
+Copyright (c) 1990-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -79,17 +79,11 @@ MIT in each case. |#
          (else (error "not a procedure" procedure)))))
 
 (define (skip-entities object)
-  (cond ((%entity? object)
-        (skip-entities (if (%entity-is-apply-hook? object)
-                           (apply-hook-procedure object)
-                           (entity-procedure object))))
-       ((%record? object)
-        (let ((method (%record-application-method object)))
-          (if method
-              (skip-entities method)
-              object)))
-       (else
-        object)))
+  (if (%entity? object)
+      (skip-entities (if (%entity-is-apply-hook? object)
+                        (apply-hook-procedure object)
+                        (entity-procedure object)))
+      object))
 \f
 (define (procedure-arity procedure)
   (let loop ((p procedure) (e 0))
@@ -291,7 +285,8 @@ MIT in each case. |#
   (system-pair-set-cdr! entity extra))
 
 (define (make-apply-hook procedure extra)
-  (make-entity (lambda args (apply procedure (cdr args)))
+  (make-entity (lambda (entity . args)
+                (apply (apply-hook-procedure entity) args))
               (hunk3-cons apply-hook-tag procedure extra)))
 
 (define (apply-hook? object)

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 55ac91f371481be4b86e0342ee5ac6ee8c93dbca..19bfb574138c144f2bb6887d3d36618a177d9857 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.58 1995/07/27 21:03:12 adams Exp $
+$Id: make.scm,v 14.59 1996/04/24 04:17:40 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -347,11 +347,14 @@ MIT in each case. |#
         ("list" . (RUNTIME LIST))
         ("symbol" . ())
         ("uproc" . (RUNTIME PROCEDURE))
+        ("fixart" . ())
+        ("random" . (RUNTIME RANDOM-NUMBER))
+        ("gentag" . (RUNTIME GENERIC-PROCEDURE))
         ("poplat" . (RUNTIME POPULATION))
-        ("record" . (RUNTIME RECORD))))
+        ("record" . (RUNTIME RECORD))
+        ("defstr" . (RUNTIME DEFSTRUCT))))
       (files2
-       '(("defstr" . (RUNTIME DEFSTRUCT))
-        ("prop1d" . (RUNTIME 1D-PROPERTY))
+       '(("prop1d" . (RUNTIME 1D-PROPERTY))
         ("events" . (RUNTIME EVENT-DISTRIBUTOR))
         ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
       (load-files
@@ -367,9 +370,12 @@ MIT in each case. |#
                      'CONSTANT-SPACE/BASE
                      constant-space/base)
   (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME RANDOM-NUMBER) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS!
+                     #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true)
+  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
+  (package-initialize '(RUNTIME DEFSTRUCT) 'INITIALIZE-STRUCTURE-TYPES! #t)
   (load-files files2)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
@@ -404,7 +410,6 @@ MIT in each case. |#
    ;; Microcode interface
    ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES! #t)
    (RUNTIME STATE-SPACE)
-   (RUNTIME MICROCODE-TABLES)
    (RUNTIME APPLY)
    (RUNTIME HASH)                      ; First GC daemon!
    (RUNTIME PRIMITIVE-IO)
@@ -417,7 +422,6 @@ MIT in each case. |#
    (RUNTIME GENSYM)
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
-   (RUNTIME RANDOM-NUMBER)
    ;; Microcode data structures
    (RUNTIME HISTORY)
    (RUNTIME LAMBDA-ABSTRACTION)
@@ -426,9 +430,20 @@ MIT in each case. |#
    (RUNTIME SCODE-WALKER)
    (RUNTIME CONTINUATION-PARSER)
    (RUNTIME PROGRAM-COPIER)
+   ;; Generic Procedures
+   ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING! #t)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER! #t)
+   ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR! #t)
+   ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS! #t)
+   ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES! #t)
+   ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE! #t)
+   ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE! #t)
    ;; Condition System
    (RUNTIME ERROR-HANDLER)
    (RUNTIME MICROCODE-ERRORS)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads
@@ -455,7 +470,7 @@ MIT in each case. |#
    (RUNTIME ILLEGAL-DEFINITIONS)
    (RUNTIME MACROS)
    (RUNTIME SYSTEM-MACROS)
-   (RUNTIME DEFSTRUCT)
+   ((RUNTIME DEFSTRUCT) INITIALIZE-DEFINE-STRUCTURE-MACRO! #t)
    (RUNTIME UNSYNTAXER)
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index cb12ac7b771721bed52970a3e210982b7504d4a6..d7f13994fc42d8041d6daf617aee2bb72f6b243f 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.269 1996/04/24 03:48:09 cph Exp $
+$Id: runtime.pkg,v 14.270 1996/04/24 04:17:17 cph Exp $
 
 Copyright (c) 1988-96 Massachusetts Institute of Technology
 
@@ -223,6 +223,8 @@ MIT in each case. |#
   (files "infstr" "infutl")
   (parent ())
   (export ()
+         *save-uncompressed-files?*
+         *uncompressed-file-lifetime*
          compiled-entry/block
          compiled-entry/dbg-object
          compiled-entry/offset
@@ -759,6 +761,8 @@ MIT in each case. |#
          add-primitive-gc-daemon!)
   (export (runtime hash-table)
          add-primitive-gc-daemon!)
+  (export (runtime generic-procedure eqht)
+         add-primitive-gc-daemon!)
   (export (runtime interrupt-handler)
          trigger-gc-daemons!)
   (initialization (initialize-package!)))
@@ -1631,6 +1635,7 @@ MIT in each case. |#
          *pp-uninterned-symbols-by-name*
          make-pretty-printer-highlight
          pp
+         pp-description
          pretty-print)
   (initialization (initialize-package!)))
 
@@ -1802,12 +1807,10 @@ MIT in each case. |#
   (export ()
          %make-record
          %record
-         %record-application-method
          %record-copy
          %record-length
          %record-ref
          %record-set!
-         %record-type-has-application-method!
          %record?
          make-record-type
          record-accessor
@@ -1816,18 +1819,17 @@ MIT in each case. |#
          record-description
          record-modifier
          record-predicate
-         record-type-application-method
          record-type-descriptor
+         record-type-dispatch-tag
          record-type-field-names
-         record-type-method
          record-type-name
-         record-type-unparser-method
          record-type?
          record-updater
          record?
-         set-record-type-application-method!
-         set-record-type-method!
-         set-record-type-unparser-method!)
+         set-record-type-unparser-method!
+         unparse-record)
+  (export (runtime record-slot-access)
+         record-type-field-index)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)
@@ -3182,4 +3184,115 @@ MIT in each case. |#
          ordered-vector-matches
          ordered-vector-minimum-match
          search-ordered-subvector
-         search-ordered-vector))
\ No newline at end of file
+         search-ordered-vector))
+
+(define-package (runtime gdbm)
+  (file-case options
+    ((load) "gdbm")
+    (else))
+  (parent ())
+  (export ()
+         gdbm-available?
+         gdbm-close
+         gdbm-delete
+         gdbm-exists?
+         gdbm-fetch
+         gdbm-firstkey
+         gdbm-nextkey
+         gdbm-open
+         gdbm-reorganize
+         gdbm-setopt
+         gdbm-store
+         gdbm-sync
+         gdbm-version
+         gdbm_cachesize
+         gdbm_fast
+         gdbm_fastmode
+         gdbm_insert
+         gdbm_newdb
+         gdbm_reader
+         gdbm_replace
+         gdbm_wrcreat
+         gdbm_writer))
+\f
+(define-package (runtime generic-procedure)
+  (files "gentag" "gencache" "generic")
+  (parent ())
+  (export ()
+         ;; tag.scm:
+         dispatch-tag-contents
+         dispatch-tag?
+         guarantee-dispatch-tag
+         make-dispatch-tag
+         set-dispatch-tag-contents!
+
+         ;; generic.scm:
+         arity-max
+         arity-min
+         built-in-dispatch-tag
+         built-in-dispatch-tags
+         condition-type:no-applicable-methods
+         dispatch-tag
+         error:no-applicable-methods
+         generic-procedure-applicable?
+         generic-procedure-arity
+         generic-procedure-name
+         generic-procedure?
+         guarantee-generic-procedure
+         make-generic-procedure
+         purge-generic-procedure-cache
+         standard-generic-procedure-tag)
+  (export (runtime generic-procedure multiplexer)
+         generic-procedure-generator
+         set-generic-procedure-generator!))
+
+(define-package (runtime generic-procedure multiplexer)
+  (files "genmult")
+  (parent ())
+  (export ()
+         add-generic-procedure-generator
+         condition-type:extra-applicable-methods
+         error:extra-applicable-methods
+         generic-procedure-default-generator
+         generic-procedure-generator-list
+         remove-generic-procedure-generator
+         remove-generic-procedure-generators
+         set-generic-procedure-default-generator!))
+
+(define-package (runtime tagged-vector)
+  (files "tvector")
+  (parent ())
+  (export ()
+         guarantee-tagged-vector
+         make-tagged-vector
+         record-slot-uninitialized
+         set-tagged-vector-element!
+         set-tagged-vector-tag!
+         tagged-vector
+         tagged-vector-element
+         tagged-vector-element-initialized?
+         tagged-vector-length
+         tagged-vector-tag
+         tagged-vector?))
+
+(define-package (runtime record-slot-access)
+  (files "recslot")
+  (parent ())
+  (export ()
+         %record-accessor
+         %record-accessor-generator
+         %record-initpred
+         %record-initpred-generator
+         %record-modifier
+         %record-modifier-generator
+         %record-slot-index
+         %record-slot-names))
+
+(define-package (runtime generic-procedure eqht)
+  (files "geneqht")
+  (parent ())
+  (export (runtime generic-procedure)
+         eqht/for-each
+         eqht/get
+         eqht/put!
+         make-eqht))
\ No newline at end of file