From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 7 Mar 2017 09:06:32 +0000 (-0800)
Subject: Change host-adapter to be ignored except on 9.2.
X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~114
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cefc33ef713854596f4944fe4fedb64c52eae9eb;p=mit-scheme.git

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 c8c7dab47..a77e5d93d 100644
--- 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 99552ee0c..b64d26235 100644
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -29,8 +29,8 @@ USA.
 
 (declare (usual-integrations))
 
-(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)