From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 8 Jan 2017 04:16:13 +0000 (-0800)
Subject: First draft of predicate tagging support.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~183
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=735c409d61722fbec13e22d1a06499739a6a2211;p=mit-scheme.git

First draft of predicate tagging support.
---

diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index e5486f7fb..f6766b528 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -236,7 +236,8 @@ USA.
    (register-predicate! dotted-list? 'dotted-list)
    (register-predicate! not-pair? 'not-pair)))
 
-;;; Registration of predicates defined earlier in the boot load
+;;; Registration of predicates defined earlier in the boot load, or
+;;; needed before their packages are initialized.
 (add-boot-init!
  (lambda ()
    ;; MIT/GNU Scheme: specialized arithmetic
@@ -246,14 +247,14 @@ USA.
    (register-predicate! exact-positive-integer? 'exact-positive-integer
 			'<= exact-integer?)
    (register-predicate! exact-rational? 'exact-rational '<= rational?)
-   (register-predicate! byte? 'byte '<= exact-nonnegative-integer?)
 
    (register-predicate! fix:fixnum? 'fixnum '<= exact-integer?)
-   (register-predicate! index-fixnum? 'index-fixnum '<= fix:fixnum?)
+   (register-predicate! index-fixnum? 'index-fixnum
+			'<= (list fix:fixnum? exact-nonnegative-integer?))
+   (register-predicate! byte? 'byte '<= index-fixnum?)
    (register-predicate! negative-fixnum? 'negative-fixnum '<= fix:fixnum?)
    (register-predicate! positive-fixnum? 'positive-fixnum
 			'<= (list fix:fixnum? exact-positive-integer?))
-
    (register-predicate! non-negative-fixnum? 'non-negative-fixnum
 			'<= (list fix:fixnum? exact-nonnegative-integer?))
    (register-predicate! non-positive-fixnum? 'non-positive-fixnum
@@ -287,22 +288,33 @@ USA.
    ;; MIT/GNU Scheme: URIs
    (register-predicate! uri? 'uniform-resource-identifier)
    (register-predicate! absolute-uri? 'absolute-uri '<= uri?)
-   (register-predicate! relative-uri? 'relative-uri '<= uri?)
-
-   ;; MIT/GNU Scheme: other stuff
+   (register-predicate! relative-uri? 'relative-uri '<= uri?)))
+
+(add-boot-init!
+ (lambda ()
+   ;; MIT/GNU Scheme: misc
    (register-predicate! 8-bit-char? '8-bit-char '<= char?)
+   (register-predicate! bit-string? 'bit-string)
+   (register-predicate! cell? 'cell)
+   (register-predicate! compiled-code-address? 'compiled-code-address)
+   (register-predicate! compiled-code-block? 'compiled-code-block)
+   (register-predicate! compiled-expression? 'compiled-expression)
+   (register-predicate! compiled-return-address? 'compiled-return-address)
    (register-predicate! dispatch-tag? 'dispatch-tag)
+   (register-predicate! ephemeron? 'ephemeron)
    (register-predicate! environment? 'environment)
    (register-predicate! equality-predicate? 'equality-predicate
 			'<= binary-procedure?)
    (register-predicate! hash-table? 'hash-table)
    (register-predicate! interned-symbol? 'interned-symbol '<= symbol?)
    (register-predicate! keyword? 'keyword '<= symbol?)
-   (register-predicate! lambda-tag? 'lambda-tag '<= symbol?)
+   (register-predicate! lambda-tag? 'lambda-tag)
    (register-predicate! named-structure? 'named-structure)
    (register-predicate! population? 'population)
+   (register-predicate! promise? 'promise)
    (register-predicate! record? 'record)
    (register-predicate! record-type? 'record-type)
+   (register-predicate! stack-address? 'stack-address)
    (register-predicate! thread? 'thread)
    (register-predicate! thread-mutex? 'thread-mutex)
    (register-predicate! undefined-value? 'undefined-value)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 33b9560b3..d92d672b7 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1735,7 +1735,9 @@ USA.
 	  thunk?
 	  unary-procedure?)
   (export (runtime continuation-parser)
-	  compiled-procedure-frame-size))
+	  compiled-procedure-frame-size)
+  (export (runtime tagging)
+	  %entity-is-apply-hook?))
 
 (define-package (runtime predicate-metadata)
   (files "predicate-metadata")
@@ -3643,6 +3645,8 @@ USA.
   (files "tagging")
   (parent (runtime))
   (export ()
+	  object->datum
+	  object->predicate
 	  object-tagger
 	  set-tagged-object-unparser-method!
 	  tag-object
diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
index e6b028de6..fd67b8723 100644
--- a/src/runtime/tagging.scm
+++ b/src/runtime/tagging.scm
@@ -24,16 +24,16 @@ USA.
 
 |#
 
-;;;; Tagged objects
+;;;; Predicates: tagging
 ;;; package: (runtime tagging)
 
 (declare (usual-integrations))
-
+
 ;;; TODO(cph): eliminate after 9.3 release:
-(define tagged-object-type #x25)
+(define-integrable tagged-object-type #x25)
 
 (define (tagged-object? object)
-  (fix:= (object-type object) tagged-object-type))
+  (fix:= tagged-object-type (object-type object)))
 
 (define (object-tagger predicate)
   (let ((tag (predicate->tag predicate)))
@@ -73,4 +73,115 @@ USA.
 	(guarantee unparser-method? unparser
 		   'set-tagged-object-unparser-method!)
 	(hash-table-set! unparser-methods tag unparser))
-      (hash-table-delete! unparser-methods tag)))
\ No newline at end of file
+      (hash-table-delete! unparser-methods tag)))
+
+(define (object->predicate object)
+  (tag->predicate (object->tag object)))
+
+(define (object->tag object)
+  (let ((code (object-type object)))
+    (or (vector-ref primitive-tags code)
+	((vector-ref primitive-tag-methods code) object))))
+
+(define (object->datum object)
+  (cond ((tagged-object? object) (system-pair-cdr object))
+        (else object)))
+
+(define primitive-tags)
+(define primitive-tag-methods)
+(add-boot-init!
+ (lambda ()
+   (set! primitive-tags
+	 (make-vector (microcode-type/code-limit)
+		      (top-tag)))
+   (set! primitive-tag-methods
+	 (make-vector (microcode-type/code-limit) #f))
+   unspecific))
+
+(add-boot-init!
+ (lambda ()
+   (define (define-primitive-predicate type-name predicate)
+     (vector-set! primitive-tags
+		  (microcode-type/name->code type-name)
+		  (predicate->tag predicate)))
+
+   (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 'ephemeron ephemeron?)
+   (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 'pair pair?)
+   (define-primitive-predicate 'primitive primitive-procedure?)
+   (define-primitive-predicate 'procedure procedure?)
+   (define-primitive-predicate 'promise promise?)
+   (define-primitive-predicate 'ratnum exact-rational?)
+   (define-primitive-predicate 'recnum number?)
+   (define-primitive-predicate 'stack-environment stack-address?)
+   (define-primitive-predicate 'string string?)
+   (define-primitive-predicate 'uninterned-symbol uninterned-symbol?)
+   (define-primitive-predicate 'vector vector?)
+   (define-primitive-predicate 'vector-1b bit-string?)
+   (define-primitive-predicate 'weak-cons weak-pair?)))
+
+(add-boot-init!
+ (lambda ()
+   (define (define-primitive-predicate-method type-name method)
+     (let ((type-code (microcode-type/name->code type-name)))
+       (vector-set! primitive-tags type-code #f)
+       (vector-set! primitive-tag-methods type-code method)))
+
+   (define-primitive-predicate-method 'tagged-object
+     system-pair-car)
+
+   (define-primitive-predicate-method 'constant
+     (let* ((constant-tags
+	     (list->vector
+	      (map predicate->tag
+		   (list boolean?
+			 undefined-value?
+			 undefined-value?
+			 lambda-tag?
+			 lambda-tag?
+			 lambda-tag?
+			 eof-object?
+			 default-object?
+			 lambda-tag?
+			 null?))))
+	    (n-tags (vector-length constant-tags)))
+       (lambda (object)
+	 (let ((datum (object-datum object)))
+	   (if (and (fix:fixnum? datum) (fix:< datum n-tags))
+	       (vector-ref constant-tags datum)
+	       (top-tag))))))
+
+   (define-primitive-predicate-method 'entity
+     (let ((apply-hook-tag (predicate->tag apply-hook?))
+	   (entity-tag (predicate->tag entity?)))
+       (lambda (object)
+	 (if (%entity-is-apply-hook? object)
+	     apply-hook-tag
+	     entity-tag))))
+
+   (define-primitive-predicate-method 'compiled-entry
+     (let ((procedure-tag (predicate->tag compiled-procedure?))
+	   (return-tag (predicate->tag compiled-return-address?))
+	   (expression-tag (predicate->tag compiled-expression?))
+	   (default-tag (predicate->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->tag record?)))
+       (lambda (object)
+	 default-tag)))))
\ No newline at end of file