Add support for tagged objects.

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index a8c718e678668088306e2700eb7d96e1f2f7c9e3..0ffe325b6bd8695aa99e3eeb1b17e395b5c8a0d1 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -449,6 +449,7 @@ USA.
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
    (RUNTIME HASH-TABLE)
+   ((RUNTIME TAGGING) INITIALIZE-UNPARSER!)
    (RUNTIME HASH)
    (RUNTIME DYNAMIC)
    (RUNTIME REGULAR-SEXPRESSION)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 50c1a900dffb1735b83c96a7c7d53c502abdad87..80450b4777673435945c5e3015157a6290d15cba 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3543,6 +3543,20 @@ USA.
          structure-tag/unparser-method)
   (initialization (initialize-package!)))
 
+(define-package (runtime tagging)
+  (files "tagging")
+  (parent (runtime))
+  (export ()
+         guarantee-tagged-object
+         make-tagged-object
+         set-tagged-object-unparser-method!
+         tagged-object-datum
+         tagged-object-tag
+         tagged-object?)
+  (export (runtime unparser)
+         get-tagged-object-unparser-method)
+  (initialization (initialize-unparser!)))
+
 (define-package (runtime reference-trap)
   (files "urtrap")
   (parent (runtime))

diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm
new file mode 100644 (file)
index 0000000..868b181
--- /dev/null
+++ b/src/runtime/tagging.scm
@@ -0,0 +1,64 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tagged objects
+;;; package: (runtime tagging)
+
+(declare (usual-integrations))
+\f
+;;; TODO(cph): eliminate after 9.3 release:
+(define tagged-object-type #x25)
+
+(define (tagged-object? object)
+  (fix:= (object-type object) tagged-object-type))
+
+(define-guarantee tagged-object "tagged object")
+
+(define (make-tagged-object tag datum)
+  (system-pair-cons tagged-object-type tag datum))
+
+(define (tagged-object-tag object)
+  (guarantee-tagged-object object 'tagged-object-tag)
+  (system-pair-car object))
+
+(define (tagged-object-datum object)
+  (guarantee-tagged-object object 'tagged-object-datum)
+  (system-pair-cdr object))
+
+(define unparser-methods)
+(define (initialize-unparser!)
+  (set! unparser-methods (make-key-weak-eqv-hash-table))
+  unspecific)
+
+(define (get-tagged-object-unparser-method object)
+  (hash-table-ref/default unparser-methods (tagged-object-tag object) #f))
+
+(define (set-tagged-object-unparser-method! tag unparser)
+  (if unparser
+      (begin
+       (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

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index f1ec0d197fed292a7a8d7d336314dfae1281e251..d02cba96d263019611291a4b44b84eb0677664e7 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -227,6 +227,7 @@ USA.
                 (RECORD ,unparse/record)
                 (RETURN-ADDRESS ,unparse/return-address)
                 (STRING ,unparse/string)
+               (TAGGED-OBJECT ,unparse/tagged-object)
                 (UNINTERNED-SYMBOL ,unparse/uninterned-symbol)
                 (VARIABLE ,unparse/variable)
                 (VECTOR ,unparse/vector)
@@ -981,4 +982,13 @@ USA.
          (if (get-param:unparse-with-datum?)
              (begin
                (*unparse-char #\space)
-               (*unparse-datum promise)))))))
\ No newline at end of file
+               (*unparse-datum promise)))))))
+
+(define (unparse/tagged-object object)
+  (cond ((get-tagged-object-unparser-method object)
+        => (lambda (method)
+             (invoke-user-method method object)))
+       (else
+        (*unparse-with-brackets 'tagged-object object
+          (lambda ()
+            (*unparse-object (tagged-object-tag object)))))))
\ No newline at end of file