From 519f332537aa58aa7ce62e74e4df1baae4892609 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 25 Jan 2018 19:52:19 -0800 Subject: [PATCH] Make sure that scode object tags are correctly computed. --- src/runtime/lambda.scm | 1 + src/runtime/predicate-tagging.scm | 65 +++++++++++++++++++++++-------- src/runtime/predicate.scm | 17 +++++++- src/runtime/runtime.pkg | 3 ++ src/runtime/scode.scm | 19 +++++++++ 5 files changed, 86 insertions(+), 19 deletions(-) diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm index bf859fea1..36776749f 100644 --- 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 36065a19b..61b08635f 100644 --- 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?) + )) (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 39243921d..4de7f0b21 100644 --- 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?))) (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 23f4d1e2e..14d42a5b5 100644 --- 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 e7091e3fd..cf166fa66 100644 --- 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)) -- 2.25.1