Make sure that scode object tags are correctly computed.

diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm
index bf859fea1b9296ba0e661ce9553995a413ddc041..36776749f337656d9008f90ecca2d8ff71ee25c8 100644 (file)
--- a/src/runtime/lambda.scm
+++ b/src/runtime/lambda.scm
@@ -405,6 +405,7 @@ USA.
 (define (scode-lambda? object)
   (or (slambda? object)
       (xlambda? object)))
+(register-predicate! scode-lambda? 'scode-lambda)
 
 (define (make-scode-lambda name required optional rest auxiliary declarations
                           body)

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index 36065a19b9179b2a0205da82d079b97da8a70e56..61b08635fc8f68c9106352e3e9aeb7908b39539a 100644 (file)
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -75,30 +75,44 @@ USA.
                  (microcode-type/name->code type-name)
                  (predicate->dispatch-tag predicate)))
 
+   (define-primitive-predicate 'assignment scode-assignment?)
    (define-primitive-predicate 'bignum exact-integer?)
    (define-primitive-predicate 'bytevector bytevector?)
    (define-primitive-predicate 'cell cell?)
    (define-primitive-predicate 'character char?)
    (define-primitive-predicate 'compiled-code-block compiled-code-block?)
+   (define-primitive-predicate 'conditional scode-conditional?)
+   (define-primitive-predicate 'control-point control-point?)
+   (define-primitive-predicate 'definition scode-definition?)
+   (define-primitive-predicate 'delay scode-delay?)
+   (define-primitive-predicate 'disjunction scode-disjunction?)
+   (define-primitive-predicate 'environment ic-environment?)
    (define-primitive-predicate 'ephemeron ephemeron?)
+   (define-primitive-predicate 'extended-lambda scode-lambda?)
    (define-primitive-predicate 'extended-procedure procedure?)
    (define-primitive-predicate 'false boolean?)
    (define-primitive-predicate 'fixnum fix:fixnum?)
    (define-primitive-predicate 'flonum flo:flonum?)
    (define-primitive-predicate 'interned-symbol interned-symbol?)
+   (define-primitive-predicate 'lambda scode-lambda?)
    (define-primitive-predicate 'pair pair?)
    (define-primitive-predicate 'primitive primitive-procedure?)
    (define-primitive-predicate 'procedure procedure?)
    (define-primitive-predicate 'promise promise?)
+   (define-primitive-predicate 'quotation scode-quotation?)
    (define-primitive-predicate 'ratnum exact-rational?)
    (define-primitive-predicate 'recnum number?)
+   (define-primitive-predicate 'sequence scode-sequence?)
    (define-primitive-predicate 'stack-environment stack-address?)
    (define-primitive-predicate 'string string?)
+   (define-primitive-predicate 'the-environment scode-the-environment?)
    (define-primitive-predicate 'unicode-string string?)
    (define-primitive-predicate 'uninterned-symbol uninterned-symbol?)
+   (define-primitive-predicate 'variable scode-variable?)
    (define-primitive-predicate 'vector vector?)
    (define-primitive-predicate 'vector-1b bit-string?)
-   (define-primitive-predicate 'weak-cons weak-pair?)))
+   (define-primitive-predicate 'weak-cons weak-pair?)
+   ))
 \f
 (add-boot-init!
  (lambda ()
@@ -107,8 +121,35 @@ USA.
        (vector-set! primitive-tags type-code #f)
        (vector-set! primitive-tag-methods type-code method)))
 
-   (define-primitive-predicate-method 'tagged-object
-     %tagged-object-tag)
+   (define (simple-alternative primary alternative)
+     (let ((primary-tag (predicate->dispatch-tag primary))
+          (alternative-tag (predicate->dispatch-tag alternative)))
+       (lambda (object)
+        (if (alternative object)
+            alternative-tag
+            primary-tag))))
+
+   (define-primitive-predicate-method 'access
+     (simple-alternative scode-access? scode-absolute-reference?))
+
+   (define-primitive-predicate-method 'combination
+     (simple-alternative scode-combination? scode-unassigned??))
+
+   (define-primitive-predicate-method 'comment
+     (simple-alternative scode-comment? scode-declaration?))
+
+   (define-primitive-predicate-method 'compiled-entry
+     (let ((procedure-tag (predicate->dispatch-tag compiled-procedure?))
+          (return-tag (predicate->dispatch-tag compiled-return-address?))
+          (expression-tag (predicate->dispatch-tag compiled-expression?))
+          (default-tag (predicate->dispatch-tag compiled-code-address?)))
+       (lambda (entry)
+        (case (system-hunk3-cxr0
+               ((ucode-primitive compiled-entry-kind 1) entry))
+          ((0) procedure-tag)
+          ((1) return-tag)
+          ((2) expression-tag)
+          (else default-tag)))))
 
    (define-primitive-predicate-method 'constant
      (let* ((constant-tags
@@ -139,22 +180,12 @@ USA.
             apply-hook-tag
             entity-tag))))
 
-   (define-primitive-predicate-method 'compiled-entry
-     (let ((procedure-tag (predicate->dispatch-tag compiled-procedure?))
-          (return-tag (predicate->dispatch-tag compiled-return-address?))
-          (expression-tag (predicate->dispatch-tag compiled-expression?))
-          (default-tag (predicate->dispatch-tag compiled-code-address?)))
-       (lambda (entry)
-        (case (system-hunk3-cxr0
-               ((ucode-primitive compiled-entry-kind 1) entry))
-          ((0) procedure-tag)
-          ((1) return-tag)
-          ((2) expression-tag)
-          (else default-tag)))))
-
    (define-primitive-predicate-method 'record
      (let ((default-tag (predicate->dispatch-tag %record?)))
        (lambda (object)
         (if (dispatch-tag? (%record-ref object 0))
             (%record-ref object 0)
-            default-tag))))))
\ No newline at end of file
+            default-tag))))
+
+   (define-primitive-predicate-method 'tagged-object
+     %tagged-object-tag)))
\ No newline at end of file

diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index 39243921ddc138dce9c21439f3b71c40554b78db..4de7f0b217a55d3bbdb4cb569c3151efe3734a10 100644 (file)
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -233,7 +233,20 @@ USA.
    (register-predicate! thunk? 'thunk '<= procedure?)
    (register-predicate! unary-procedure? 'unary-procedure '<= procedure?)
    (register-predicate! unparser-method? 'unparser-method '<= procedure?)
-   (register-predicate! bundle? 'bundle '<= entity?)))
+   (register-predicate! bundle? 'bundle '<= entity?)
+
+   ;; MIT/GNU Scheme: environments
+   (register-predicate! environment? 'environment)
+   (register-predicate! top-level-environment? 'top-level-environment
+                       '<= environment?)
+   (register-predicate! system-global-environment? 'system-global-environment
+                       '<= top-level-environment?)
+   (register-predicate! ic-environment? 'ic-environment
+                       '<= top-level-environment?)
+   (register-predicate! closure-ccenv? 'compiled-code-closure-environment
+                       '<= environment?)
+   (register-predicate! stack-ccenv? 'compiled-code-stack-environment
+                       '<= environment?)))
 \f
 (add-boot-init!
  (lambda ()
@@ -248,8 +261,8 @@ USA.
    (register-predicate! compiled-code-block? 'compiled-code-block)
    (register-predicate! compiled-expression? 'compiled-expression)
    (register-predicate! compiled-return-address? 'compiled-return-address)
+   (register-predicate! control-point? 'control-point)
    (register-predicate! ephemeron? 'ephemeron)
-   (register-predicate! environment? 'environment)
    (register-predicate! equality-predicate? 'equality-predicate
                        '<= binary-procedure?)
    (register-predicate! interned-symbol? 'interned-symbol '<= symbol?)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 23f4d1e2ed8d110d1400aa1f111c18dbdf059c11..14d42a5b527380be938e7a07903ddfab4c2ae285 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1968,6 +1968,9 @@ USA.
          ic-environment/procedure)
   (export (runtime debugging-info)
          stack-frame/environment)
+  (export (runtime predicate)
+         closure-ccenv?
+         stack-ccenv?)
   (initialization (initialize-package!)))
 
 (define-package (runtime environment-inspector)

diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm
index e7091e3fd2ac27fd6c6c51c96f9d882cbe687b1f..cf166fa6660266b65d26f7ff69a603b52e43b56c 100644 (file)
--- a/src/runtime/scode.scm
+++ b/src/runtime/scode.scm
@@ -47,6 +47,7 @@ USA.
 
 (define (scode-constant? object)
   (not (scode-expression? object)))
+(register-predicate! scode-constant? 'scode-constant)
 
 ;;;; Quotation
 
@@ -57,6 +58,7 @@ USA.
 
 (define (scode-quotation? object)
   (object-type? (ucode-type quotation) object))
+(register-predicate! scode-quotation? 'scode-quotation)
 
 (define (scode-quotation-expression quotation)
   (guarantee scode-quotation? quotation 'scode-quotation-expression)
@@ -70,6 +72,7 @@ USA.
 
 (define (scode-variable? object)
   (object-type? (ucode-type variable) object))
+(register-predicate! scode-variable? 'scode-variable)
 
 (define (scode-variable-name variable)
   (guarantee scode-variable? variable 'scode-variable-name)
@@ -85,6 +88,7 @@ USA.
 
 (define (scode-definition? object)
   (object-type? (ucode-type definition) object))
+(register-predicate! scode-definition? 'scode-definition)
 
 (define (scode-definition-name definition)
   (guarantee scode-definition? definition 'scode-definition-name)
@@ -104,6 +108,7 @@ USA.
 
 (define (scode-assignment? object)
   (object-type? (ucode-type assignment) object))
+(register-predicate! scode-assignment? 'scode-assignment)
 
 (define (scode-assignment-name assignment)
   (guarantee scode-assignment? assignment 'scode-assignment-name)
@@ -122,6 +127,7 @@ USA.
 
 (define (scode-comment? object)
   (object-type? (ucode-type comment) object))
+(register-predicate! scode-comment? 'scode-comment)
 
 (define (scode-comment-text comment)
   (guarantee scode-comment? comment 'scode-comment-text)
@@ -145,6 +151,7 @@ USA.
        (let ((text (scode-comment-text object)))
         (and (pair? text)
              (eq? (car text) declaration-tag)))))
+(register-predicate! scode-declaration? 'scode-declaration '<= scode-comment?)
 
 (define declaration-tag
   ((ucode-primitive string->symbol) "#[declaration]"))
@@ -164,6 +171,7 @@ USA.
 
 (define (scode-the-environment? object)
   (object-type? (ucode-type the-environment) object))
+(register-predicate! scode-the-environment? 'scode-the-environment)
 
 ;;;; Access
 
@@ -175,6 +183,7 @@ USA.
 
 (define (scode-access? object)
   (object-type? (ucode-type access) object))
+(register-predicate! scode-access? 'scode-access)
 
 (define (scode-access-environment access)
   (guarantee scode-access? access 'scode-access-environment)
@@ -192,6 +201,8 @@ USA.
 (define (scode-absolute-reference? object)
   (and (scode-access? object)
        (system-global-environment? (scode-access-environment object))))
+(register-predicate! scode-absolute-reference? 'scode-absolute-reference
+                    '<= scode-access?)
 
 (define (scode-absolute-reference-name reference)
   (guarantee scode-absolute-reference? reference 'scode-absolute-reference-name)
@@ -210,6 +221,7 @@ USA.
 
 (define (scode-delay? object)
   (object-type? (ucode-type delay) object))
+(register-predicate! scode-delay? 'scode-delay)
 
 (define (scode-delay-expression delay)
   (guarantee scode-delay? delay 'scode-delay-expression)
@@ -228,6 +240,7 @@ USA.
 
 (define (scode-sequence? object)
   (object-type? (ucode-type sequence) object))
+(register-predicate! scode-sequence? 'scode-sequence)
 
 (define (scode-sequence-actions expression)
   (if (scode-sequence? expression)
@@ -254,6 +267,7 @@ USA.
 
 (define (scode-combination? object)
   (object-type? (ucode-type combination) object))
+(register-predicate! scode-combination? 'scode-combination)
 
 (define (scode-combination-operator combination)
   (guarantee scode-combination? combination 'scode-combination-operator)
@@ -285,6 +299,8 @@ USA.
         (and (= 2 (length operands))
              (scode-the-environment? (car operands))
              (symbol? (cadr operands))))))
+(register-predicate! scode-unassigned?? 'scode-unassigned?
+                    '<= scode-combination?)
 
 (define (scode-unassigned?-name expression)
   (guarantee scode-unassigned?? expression 'scode-unassigned?-name)
@@ -300,6 +316,7 @@ USA.
 
 (define (scode-conditional? object)
   (object-type? (ucode-type conditional) object))
+(register-predicate! scode-conditional? 'scode-conditional)
 
 (define undefined-scode-conditional-branch unspecific)
 
@@ -324,6 +341,7 @@ USA.
 
 (define (scode-disjunction? object)
   (object-type? (ucode-type disjunction) object))
+(register-predicate! scode-disjunction? 'scode-disjunction)
 
 (define (scode-disjunction-predicate disjunction)
   (guarantee scode-disjunction? disjunction 'scode-disjunction-predicate)
@@ -353,6 +371,7 @@ USA.
 (define (scode-lambda? object)
   (or (slambda? object)
       (xlambda? object)))
+(register-predicate! scode-lambda? 'scode-lambda)
 
 (define (scode-lambda-name lambda)
   (cond ((slambda? lambda) (slambda-name lambda))