Rewrite microcode-tables.scm for simplicity.

Also add a 'fixed-objects boot-actions list and change record.scm to use it.

diff --git a/doc/ref-manual/os-interface.texi b/doc/ref-manual/os-interface.texi
index 7eef0277da2dc0373d74c8d22d68dcc45baa4b37..28176015eeb9fd76edd9a21d3ebc07a4ce8c844c 100644 (file)
--- a/doc/ref-manual/os-interface.texi
+++ b/doc/ref-manual/os-interface.texi
@@ -2505,14 +2505,13 @@ This section contains assorted operating-system facilities that don't
 fit into other categories.
 
 @defvr variable microcode-id/operating-system
-@defvrx variable microcode-id/operating-system-name
+@defvrx {obsolete variable} microcode-id/operating-system-name
 @code{microcode-id/operating-system} is bound to a symbol that specifies
 the type of operating system that Scheme is running under.  There are
 two possible values: @code{unix} or @code{nt}.
 
-@code{microcode-id/operating-system-name} is a string containing the
-same name as @code{microcode-id/operating-system}; the latter is created
-by interning the former as a symbol.
+The @strong{deprecated} variable @code{microcode-id/operating-system-name} is
+a string that's equivalent to @code{microcode-id/operating-system}.
 @end defvr
 
 @defvr variable microcode-id/operating-system-variant

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index b7044064e8c28cf321e7c6f20fd54722ccf32d61..8df7a12ce7ec34e24311f60329863cde88414a62 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -447,9 +447,8 @@ USA.
 (package-initialization-sequence
  '(
    ;; Microcode interface
-   ((runtime microcode-tables) read-microcode-tables!)
+   (runtime microcode-tables)
    (runtime apply)
-   ((runtime record) initialize-applicator-context!)
    (runtime primitive-io)
    (runtime system-clock)
    ((runtime gc-finalizer) initialize-events!)

diff --git a/src/runtime/microcode-tables.scm b/src/runtime/microcode-tables.scm
index ed5b1eecd054c89ed0246e815b1ec3dd7ebc5232..76c5a49c33d71d0cba114d9ef84b41d6ab1dd77c 100644 (file)
--- a/src/runtime/microcode-tables.scm
+++ b/src/runtime/microcode-tables.scm
@@ -24,101 +24,16 @@ USA.
 
 |#
 
-;;;; Microcode Name <-> Code Maps
+;;;; Microcode shared object tables
 ;;; package: (runtime microcode-tables)
 
 (declare (usual-integrations))
 \f
-(define (read-microcode-tables!)
-  (set! identification-vector ((ucode-primitive microcode-identify)))
-  (set! errors-slot (fixed-object/name->code 'microcode-errors-vector))
-  (set! identifications-slot
-       (fixed-object/name->code 'microcode-identification-vector))
-  (set! returns-slot (fixed-object/name->code 'microcode-returns-vector))
-  (set! terminations-slot
-       (fixed-object/name->code 'microcode-terminations-vector))
-  (set! types-slot (fixed-object/name->code 'microcode-types-vector))
-  (set! non-object-slot (fixed-object/name->code 'non-object))
-  (set! system-call-names-slot (fixed-object/name->code 'system-call-names))
-  (set! system-call-errors-slot (fixed-object/name->code 'system-call-errors))
-  (set! microcode-version-string
-       (microcode-identification-item 'microcode-version))
-  (set! char:newline (microcode-identification-item 'newline-char))
-  (set! microcode-id/floating-mantissa-bits
-       (microcode-identification-item 'flonum-mantissa-length))
-  (set! microcode-id/floating-epsilon
-       (microcode-identification-item 'flonum-epsilon))
-  (let ((name (microcode-identification-item 'os-name-string)))
-    (set! microcode-id/operating-system (intern name))
-    (set! microcode-id/operating-system-name name))
-  (set! microcode-id/operating-system-variant
-       (microcode-identification-item 'os-variant-string))
-  (set! microcode-id/stack-type
-       (let ((string (microcode-identification-item 'stack-type-string)))
-         (cond ((string? string) (intern string))
-               ((not string) 'standard)
-               (else (error "Illegal stack type:" string)))))
-  (set! microcode-id/machine-type
-       (or (microcode-identification-item 'machine-type-string #f)
-           "unknown-machine"))
-  (set! microcode-id/compiled-code-type
-       (intern (or (microcode-identification-item 'cc-arch-string #f)
-                   "unknown")))
-  (set! microcode-id/tty-x-size
-       (microcode-identification-item 'console-width))
-  (set! microcode-id/tty-y-size
-       (microcode-identification-item 'console-height))
-
-  unspecific)
-
-(define (intern string)
-  ((ucode-primitive string->symbol)
-   (let ((size ((ucode-primitive string-length) string)))
-     (let ((result ((ucode-primitive string-allocate) size)))
-       ((ucode-primitive substring-move-right!) string 0 size result 0)
-       ((ucode-primitive substring-downcase!) result 0 size)
-       result))))
-
-(define (get-microcode-version-string)
-  microcode-version-string)
-
-(define (get-microcode-version-numbers)
-  (map (lambda (s) (or (string->number s) s))
-       (burst-string microcode-version-string #\. #f)))
-
-(define microcode-version-string)
-(define char:newline)
-(define microcode-id/tty-x-size)
-(define microcode-id/tty-y-size)
-(define microcode-id/floating-mantissa-bits)
-(define microcode-id/floating-epsilon)
-(define microcode-id/operating-system)
-(define microcode-id/operating-system-name)
-(define microcode-id/operating-system-variant)
-(define microcode-id/stack-type)
-(define microcode-id/machine-type)
-(define microcode-id/compiled-code-type)
-
-(define (microcode-id/operating-system-suffix #!optional os-type)
-  (case (if (default-object? os-type)
-           microcode-id/operating-system
-           os-type)
-    ((nt) "w32")
-    ((unix) "unx")
-    (else (error "Unknown operating system:" os-type))))
-\f
 (define-integrable fixed-objects-slot 15)
-(define non-object-slot)
 
 (define (fixed-object/name->code name)
   (microcode-table-search fixed-objects-slot name))
 
-(define (fixed-object/code->name code)
-  (microcode-table-ref fixed-objects-slot code))
-
-(define (fixed-object/code-limit)
-  (vector-length (vector-ref (get-fixed-objects-vector) fixed-objects-slot)))
-
 (define (fixed-objects-vector-slot name)
   (or (fixed-object/name->code name)
       (error:bad-range-argument name 'fixed-objects-vector-slot)))
@@ -148,9 +63,6 @@ USA.
 (define (update-fixed-objects-item! name updater)
   ((fixed-objects-updater name) updater))
 
-(define (microcode-object/unassigned)
-  (vector-ref (get-fixed-objects-vector) non-object-slot))
-
 (define (microcode-table-search slot name)
   (let ((vector (vector-ref (get-fixed-objects-vector) slot)))
     (let ((end (vector-length vector)))
@@ -163,45 +75,28 @@ USA.
                   i
                   (loop (fix:+ i 1)))))))))
 
-(define (microcode-table-entry slot index)
-  (let ((vector (vector-ref (get-fixed-objects-vector) slot)))
-    (and (fix:< index (vector-length vector))
-        (vector-ref vector index))))
-
 (define (microcode-table-ref slot index)
-  (let ((entry (microcode-table-entry slot index)))
-    (if (pair? entry)
-       (car entry)
-       entry)))
+  (let ((v (vector-ref (get-fixed-objects-vector) slot)))
+    (and (fix:< index (vector-length v))
+        (let ((entry (vector-ref v index)))
+          (if (pair? entry)
+              (car entry)
+              entry)))))
 \f
-(define returns-slot)
+(define-deferred returns-slot
+  (fixed-object/name->code 'microcode-returns-vector))
 
 (define (microcode-return/name->code name)
-  (microcode-table-search returns-slot
-                         (let ((p
-                                (find (lambda (p)
-                                        (memq name (cdr p)))
-                                      returns-aliases)))
-                           (if p
-                               (car p)
-                               name))))
+  (microcode-table-search returns-slot name))
 
 (define (microcode-return/code->name code)
   (microcode-table-ref returns-slot code))
 
-(define (microcode-return/code->names code)
-  (let ((name (microcode-table-entry types-slot code)))
-    (if name
-       (or (assq name returns-aliases)
-           (list name))
-       '())))
-
 (define (microcode-return/code-limit)
   (vector-length (vector-ref (get-fixed-objects-vector) returns-slot)))
 
-(define returns-aliases '())
-
-(define errors-slot)
+(define-deferred errors-slot
+  (fixed-object/name->code 'microcode-errors-vector))
 
 (define (microcode-error/name->code name)
   (microcode-table-search errors-slot name))
@@ -212,7 +107,8 @@ USA.
 (define (microcode-error/code-limit)
   (vector-length (vector-ref (get-fixed-objects-vector) errors-slot)))
 
-(define terminations-slot)
+(define-deferred terminations-slot
+  (fixed-object/name->code 'microcode-terminations-vector))
 
 (define (microcode-termination/name->code name)
   (microcode-table-search terminations-slot name))
@@ -223,37 +119,26 @@ USA.
 (define (microcode-termination/code-limit)
   (vector-length (vector-ref (get-fixed-objects-vector) terminations-slot)))
 
-(define identifications-slot)
-(define identification-vector)
-
-(define (microcode-identification-vector-slot name #!optional error?)
-  (let ((v (microcode-table-search identifications-slot name)))
-    (if (and (not v) (if (default-object? error?) #t error?))
-       (error:bad-range-argument name 'microcode-identification-vector-slot))
-    v))
-
-(define (microcode-identification-item name #!optional error?)
-  (let ((slot (microcode-identification-vector-slot name error?)))
-    (and slot
-        (vector-ref identification-vector slot))))
-
-(define system-call-names-slot)
+(define-deferred system-call-names-slot
+  (fixed-object/name->code 'system-call-names))
 
 (define (microcode-system-call/name->code name)
   (microcode-table-search system-call-names-slot name))
 
 (define (microcode-system-call/code->name code)
   (microcode-table-ref system-call-names-slot code))
-
-(define system-call-errors-slot)
+\f
+(define-deferred system-call-errors-slot
+  (fixed-object/name->code 'system-call-errors))
 
 (define (microcode-system-call-error/name->code name)
   (microcode-table-search system-call-errors-slot name))
 
 (define (microcode-system-call-error/code->name code)
   (microcode-table-ref system-call-errors-slot code))
-\f
-(define types-slot)
+
+(define-deferred types-slot
+  (fixed-object/name->code 'microcode-types-vector))
 
 (define (microcode-type/name->code name)
   (microcode-table-search types-slot
@@ -268,13 +153,6 @@ USA.
 (define (microcode-type/code->name code)
   (microcode-table-ref types-slot code))
 
-(define (microcode-type/code->names code)
-  (let ((name (microcode-table-entry types-slot code)))
-    (if name
-       (or (assq name type-aliases)
-           (list name))
-       '())))
-
 (define (microcode-type/code-limit)
   (vector-length (vector-ref (get-fixed-objects-vector) types-slot)))
 
@@ -291,4 +169,65 @@ USA.
     (hunk3-a unmarked-history)
     (triple hunk3 hunk3-b marked-history)
     (reference-trap unassigned)
-    (recnum complex)))
\ No newline at end of file
+    (recnum complex)))
+\f
+;;;; Microcode identification
+
+(define-deferred identifications-slot
+  (fixed-object/name->code 'microcode-identification-vector))
+
+(define identification-vector)
+(define microcode-version-string)
+(define microcode-id/floating-mantissa-bits)
+(define microcode-id/floating-epsilon)
+(define microcode-id/operating-system)
+(define microcode-id/operating-system-name)
+(define microcode-id/operating-system-variant)
+(define microcode-id/machine-type)
+(define microcode-id/compiled-code-type)
+(define (read-microcode-identification!)
+  (set! identification-vector
+       ((ucode-primitive microcode-identify)))
+  (set! microcode-version-string
+       (microcode-identification-item 'microcode-version))
+  (set! microcode-id/floating-mantissa-bits
+       (microcode-identification-item 'flonum-mantissa-length))
+  (set! microcode-id/floating-epsilon
+       (microcode-identification-item 'flonum-epsilon))
+  (set! microcode-id/operating-system-name
+       (microcode-identification-item 'os-name-string))
+  (set! microcode-id/operating-system
+       (intern microcode-id/operating-system-name))
+  (set! microcode-id/operating-system-variant
+       (microcode-identification-item 'os-variant-string))
+  (set! microcode-id/machine-type
+       (microcode-identification-item 'machine-type-string "unknown"))
+  (set! microcode-id/compiled-code-type
+       (intern (microcode-identification-item 'cc-arch-string "unknown")))
+  unspecific)
+
+(add-boot-init!
+ (lambda ()
+   (read-microcode-identification!)
+   (run-deferred-boot-actions 'fixed-objects)))
+
+(define (microcode-identification-item name #!optional default-value)
+  (let ((index (microcode-table-search identifications-slot name)))
+    (if index
+       (vector-ref identification-vector index)
+       (begin
+         (if (default-object? default-value)
+             (error:bad-range-argument name 'microcode-identification-item))
+         default-value))))
+
+(define (get-microcode-version-numbers)
+  (map (lambda (s) (or (string->number s) s))
+       (burst-string microcode-version-string #\. #f)))
+
+(define (microcode-id/operating-system-suffix #!optional os-type)
+  (case (if (default-object? os-type)
+           microcode-id/operating-system
+           os-type)
+    ((nt) "w32")
+    ((unix) "unx")
+    (else (error "Unknown operating system:" os-type))))
\ No newline at end of file

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 537a00388e23272e892097da63fe179fe80d3ddb..8dbb87ea783c04186c31b394d1eb737d7adcc707 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -202,10 +202,11 @@ USA.
 (define-integrable (%set-record-type-applicator! record-type applicator)
   (%dispatch-tag-extra-set! record-type 4 applicator))
 
-(define (initialize-applicator-context!)
-  (set-fixed-objects-item! 'record-dispatch-tag %record-metatag)
-  (set-fixed-objects-item! 'record-applicator-index
-                          (%dispatch-tag-extra-index 4)))
+(defer-boot-action 'fixed-objects
+  (lambda ()
+    (set-fixed-objects-item! 'record-dispatch-tag %record-metatag)
+    (set-fixed-objects-item! 'record-applicator-index
+                            (%dispatch-tag-extra-index 4))))
 
 (define-integrable (%record-type-n-fields record-type)
   (vector-length (%record-type-field-names record-type)))
@@ -300,7 +301,7 @@ USA.
   (vector-set! %proxied-record-types (%record-type-proxy->index proxy) type))
 
 (define %proxied-record-types)
-(defer-boot-action 'record-procedures
+(defer-boot-action 'fixed-objects
   (lambda ()
     (set! %proxied-record-types (fixed-objects-item 'proxied-record-types))
     unspecific))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2371907101b9158efec92f592777f9d7d7db6bc1..5eb537305488bf9bd11ae0f013d44dacc47a4b46 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3202,28 +3202,24 @@ USA.
 (define-package (runtime microcode-tables)
   (files "microcode-tables")
   (parent (runtime))
+  (export () deprecated:microcode-tables
+         microcode-id/operating-system-name)
   (export ()
          microcode-id/compiled-code-type
          microcode-id/floating-epsilon
          microcode-id/floating-mantissa-bits
          microcode-id/machine-type
          microcode-id/operating-system
-         microcode-id/operating-system-name
          microcode-id/operating-system-suffix
          microcode-id/operating-system-variant
-         microcode-id/stack-type
-         microcode-id/tty-x-size
-         microcode-id/tty-y-size
          microcode-type/code-limit)
   (export (runtime)
-         char:newline
          fixed-objects-accessor
          fixed-objects-item
          fixed-objects-modifier
          fixed-objects-updater
          get-microcode-version-numbers
          microcode-type/code->name
-         microcode-type/code->names
          microcode-type/name->code
          set-fixed-objects-item!
          update-fixed-objects-item!)
@@ -3255,7 +3251,7 @@ USA.
          microcode-termination/code-limit
          microcode-termination/name->code)
   (export (runtime save/restore)
-         read-microcode-tables!)
+         read-microcode-identification!)
   (initialization (initialize-package!)))
 
 (define-package (runtime number)

diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm
index ab2018634a20b6f9e78fde00f626fa16744332fd..0176b061a60ff6e221c4ec98ffbcea5465727e1e 100644 (file)
--- a/src/runtime/savres.scm
+++ b/src/runtime/savres.scm
@@ -79,7 +79,7 @@ USA.
                           (set! time-world-saved time)
                           (if (string? id) unspecific #f)))))))
                 ((ucode-primitive set-fixed-objects-vector!) fixed-objects))))
-          (read-microcode-tables!)
+          (read-microcode-identification!)
           (lambda ()
             (set! time-world-saved time)
             (set! time-world-restored (get-universal-time))