From cefc33ef713854596f4944fe4fedb64c52eae9eb Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 7 Mar 2017 01:06:32 -0800 Subject: [PATCH] Change host-adapter to be ignored except on 9.2. Also fix typo in tagged-object type name. --- src/runtime/host-adapter.scm | 130 +++++++++++++++--------------- src/runtime/predicate-tagging.scm | 6 +- 2 files changed, 68 insertions(+), 68 deletions(-) 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) -- 2.25.1