From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 17 Jan 2017 21:07:19 +0000 (-0800)
Subject: Implement predicate-tagging strategies.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~122
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5fb683b9c07cf957c8a375224b4e7f92d28e0cfd;p=mit-scheme.git

Implement predicate-tagging strategies.
---

diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm
index 490fdfe9f..9d17c1bab 100644
--- a/src/runtime/predicate-tagging.scm
+++ b/src/runtime/predicate-tagging.scm
@@ -74,7 +74,73 @@ USA.
 		   'set-tagged-object-unparser-method!)
 	(hash-table-set! unparser-methods tag unparser))
       (hash-table-delete! unparser-methods tag)))
+
+;;;; Tagging strategies
+
+(define (predicate-tagging-strategy:never name predicate make-tag)
+
+  (define (constructor object #!optional caller)
+    (guarantee predicate object caller)
+    object)
+
+  (define (accessor object #!optional caller)
+    (guarantee predicate object caller)
+    object)
+
+  (define tag
+    (make-tag predicate constructor accessor))
+
+  tag)
+
+(define (predicate-tagging-strategy:always name datum-test make-tag)
+
+  (define (predicate object)
+    (and (tagged-object? object)
+         (tag<= (tagged-object-tag object) tag)
+         (datum-test (tagged-object-datum object))))
+
+  (define (constructor datum #!optional caller)
+    (if (not (datum-test datum))
+	(error:wrong-type-argument datum (string "datum for " name) caller))
+    (make-tagged-object tag datum))
+
+  (define (accessor object #!optional caller)
+    (guarantee predicate object caller)
+    object)
+
+  (define tag
+    (make-tag predicate constructor tagged-object-datum))
 
+  tag)
+
+(define (predicate-tagging-strategy:optional name datum-test make-tag)
+
+  (define (predicate object)
+    (or (tagged-object-test object)
+        (datum-test object)))
+
+  (define (tagged-object-test object)
+    (and (tagged-object? object)
+	 (tag<= (tagged-object-tag object) tag)
+	 (datum-test (tagged-object-datum object))))
+
+  (define (constructor datum #!optional caller)
+    (if (not (datum-test datum))
+	(error:wrong-type-argument datum (string "datum for " name) caller))
+    (if (eq? tag (object->tag datum))
+        datum
+        (make-tagged-object tag datum)))
+
+  (define (accessor object #!optional caller)
+    (cond ((tagged-object-test object) (tagged-object-datum object))
+	  ((datum-test object) object)
+	  (else (error:not-a predicate object caller))))
+
+  (define tag
+    (make-tag predicate constructor accessor))
+
+  tag)
+
 (define (object->predicate object)
   (tag->predicate (object->tag object)))
 
@@ -86,7 +152,7 @@ USA.
 (define (object->datum object)
   (cond ((tagged-object? object) (system-pair-cdr object))
         (else object)))
-
+
 (define primitive-tags)
 (define primitive-tag-methods)
 (add-boot-init!
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index bf9d8392a..c954da260 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1862,6 +1862,9 @@ USA.
 	  object->datum
 	  object->predicate
 	  object-tagger
+	  predicate-tagging-strategy:always
+	  predicate-tagging-strategy:never
+	  predicate-tagging-strategy:optional
 	  set-tagged-object-unparser-method!
 	  tag-object
 	  tagged-object-datum