Change host-adapter to be ignored except on 9.2.

Also fix typo in tagged-object type name.

diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index c8c7dab47733a13e8e603404193afdfa3e5c571b..a77e5d93d89b0fb0c8c4196f39a693eb544e2e55 100644 (file)
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -36,69 +36,69 @@ USA.
 ;;; only until the new runtime is released.  They assume the host is
 ;;; the current release (9.2 as of March 2017).
 
-(let ((env (->environment '())))
-  (eval '
-(define random-bytevector random-byte-vector) env)
-  (eval '
-(define (guarantee predicate object #!optional caller)
-  (if (predicate object)
-      object
-      (error "Not a:" predicate object))) env)
-  (eval '
-(define (microcode-type name)
-  (or (microcode-type/name->code name)
-      (cond ((eq? name 'bytevector) #x33)
-           ((eq? name 'tagged) #x25)
-           (else #t))
-      (error "MICROCODE-TYPE: Unknown name" name))) env))
+(if (string=? "9.2" (get-subsystem-version-string "release"))
+    (begin
+      (eval
+       '(begin
+         (define random-bytevector random-byte-vector)
 
-;; Make new CREF's .pkds usable.
-(let ((env (->environment '(package))))
-  (eval '
-(define (link-description? object)
-  (and (vector? object)
-       (cond ((fix:= (vector-length object) 2)
-             (and (symbol? (vector-ref object 0))
-                  (package-name? (vector-ref object 1))))
-            ((fix:= (vector-length object) 3)
-             (and (symbol? (vector-ref object 0))
-                  (package-name? (vector-ref object 1))
-                  (symbol? (vector-ref object 2))))
-            ((fix:= (vector-length object) 4)
-             (and (symbol? (vector-ref object 0))
-                  (package-name? (vector-ref object 1))
-                  (symbol? (vector-ref object 2))
-                  (or (eq? #f (vector-ref object 3))
-                      (eq? 'deprecated (vector-ref object 3)))))
-            (else #f))))
-       env)
-  (eval '
-(define (create-links-from-description description)
-  (let ((environment
-        (find-package-environment (package-description/name description))))
-    (let ((bindings (package-description/exports description)))
-      (let ((n (vector-length bindings)))
-       (do ((i 0 (fix:+ i 1)))
-           ((fix:= i n))
-         (let ((binding (vector-ref bindings i)))
-           (link-variables (find-package-environment (vector-ref binding 1))
-                           (if (fix:= (vector-length binding) 3)
-                               (vector-ref binding 2)
-                               (vector-ref binding 0))
-                           environment
-                           (vector-ref binding 0))))))
-    (let ((bindings (package-description/imports description)))
-      (let ((n (vector-length bindings)))
-       (do ((i 0 (fix:+ i 1)))
-           ((fix:= i n))
-         (let ((binding (vector-ref bindings i)))
-           (let ((source-environment
-                  (find-package-environment (vector-ref binding 1)))
-                 (source-name
-                  (if (fix:>= (vector-length binding) 3)
-                      (vector-ref binding 2)
-                      (vector-ref binding 0))))
-             (guarantee-binding source-environment source-name)
-             (link-variables environment (vector-ref binding 0)
-                             source-environment source-name))))))))
-       env))
\ No newline at end of file
+         (define (guarantee predicate object #!optional caller)
+           (if (predicate object)
+               object
+               (error "Not a:" predicate object)))
+
+         (define (microcode-type name)
+           (or (microcode-type/name->code name)
+               (cond ((eq? name 'bytevector) #x33)
+                     ((eq? name 'tagged-object) #x25)
+                     (else #t))
+               (error "MICROCODE-TYPE: Unknown name" name))))
+       (->environment '()))
+      ;; Make new CREF's .pkds usable.
+      (eval
+       '(begin
+         (define (link-description? object)
+           (and (vector? object)
+                (cond ((fix:= (vector-length object) 2)
+                       (and (symbol? (vector-ref object 0))
+                            (package-name? (vector-ref object 1))))
+                      ((fix:= (vector-length object) 3)
+                       (and (symbol? (vector-ref object 0))
+                            (package-name? (vector-ref object 1))
+                            (symbol? (vector-ref object 2))))
+                      ((fix:= (vector-length object) 4)
+                       (and (symbol? (vector-ref object 0))
+                            (package-name? (vector-ref object 1))
+                            (symbol? (vector-ref object 2))
+                            (or (eq? #f (vector-ref object 3))
+                                (eq? 'deprecated (vector-ref object 3)))))
+                      (else #f))))
+         (define (create-links-from-description description)
+           (let ((environment
+                  (find-package-environment (package-description/name description))))
+             (let ((bindings (package-description/exports description)))
+               (let ((n (vector-length bindings)))
+                 (do ((i 0 (fix:+ i 1)))
+                     ((fix:= i n))
+                   (let ((binding (vector-ref bindings i)))
+                     (link-variables (find-package-environment (vector-ref binding 1))
+                                     (if (fix:= (vector-length binding) 3)
+                                         (vector-ref binding 2)
+                                         (vector-ref binding 0))
+                                     environment
+                                     (vector-ref binding 0))))))
+             (let ((bindings (package-description/imports description)))
+               (let ((n (vector-length bindings)))
+                 (do ((i 0 (fix:+ i 1)))
+                     ((fix:= i n))
+                   (let ((binding (vector-ref bindings i)))
+                     (let ((source-environment
+                            (find-package-environment (vector-ref binding 1)))
+                           (source-name
+                            (if (fix:>= (vector-length binding) 3)
+                                (vector-ref binding 2)
+                                (vector-ref binding 0))))
+                       (guarantee-binding source-environment source-name)
+                       (link-variables environment (vector-ref binding 0)
+                                       source-environment source-name)))))))))
+       (->environment '(package)))))
\ No newline at end of file

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index 99552ee0ccdf84d5f67685ba2682559de27c781e..b64d262351480b72fecdbcd41b1469533d332ed9 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -29,8 +29,8 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (tagged-object? object)
-  (fix:= (ucode-type tagged) (object-type object)))
+(define-integrable (tagged-object? object)
+  (object-type? (ucode-type tagged-object) object))
 
 (define (object-tagger predicate)
   (let ((tag (predicate->tag predicate)))
@@ -44,7 +44,7 @@ USA.
   (tag->predicate (tagged-object-tag object)))
 
 (define-integrable (make-tagged-object tag datum)
-  (system-pair-cons (ucode-type tagged) tag datum))
+  (system-pair-cons (ucode-type tagged-object) tag datum))
 
 (define (tagged-object-tag object)
   (guarantee tagged-object? object 'tagged-object-tag)