From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 5 Jan 2017 21:38:18 +0000 (-0800)
Subject: Add support for tagged objects.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~222
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=50203862e58a3f43455ccca1fe375d71a5fdf75d;p=mit-scheme.git

Add support for tagged objects.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index a8c718e67..0ffe325b6 100644
--- 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 50c1a900d..80450b477 100644
--- 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
index 000000000..868b181a1
--- /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))
+
+;;; 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 f1ec0d197..d02cba96d 100644
--- 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