From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Jan 2018 20:09:33 +0000 (-0500)
Subject: Convert record support to use new predicate dispatchers.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~403
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7f6f59ec9bcb37e9945f83718f6c6193f4c2c1e0;p=mit-scheme.git

Convert record support to use new predicate dispatchers.
---

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 78b84bc70..2ae868bd9 100644
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -142,7 +142,7 @@ USA.
 
 (define (tagged-vector/description object)
   (cond ((named-structure? object)
-	 named-structure/description)
+	 pp-description)
 	((tagged-vector? object)
 	 (vector-tag-description (tagged-vector/tag object)))
 	(else
diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm
index 9f8b2d8e9..65a71c0e2 100644
--- a/src/runtime/debug.scm
+++ b/src/runtime/debug.scm
@@ -825,7 +825,7 @@ USA.
       (for-each (lambda (element)
 		  (newline port)
 		  (debugger-pp element 0 port))
-		(named-structure/description (dstate/subproblem dstate))))))
+		(pp-description (dstate/subproblem dstate))))))
 
 (define-command (command/print-frame-elements dstate port)
   (debugger-presentation
diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 354e47b6b..daa01d73e 100644
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -180,15 +180,7 @@ USA.
 
    (define-predicate-dispatch-default-handler pp-description
      (lambda (object)
-       (cond ((named-structure? object)
-	      (named-structure/description object))
-	     ((%record? object)		; unnamed record
-	      (let loop ((i (- (%record-length object) 1)) (d '()))
-		(if (< i 0)
-		    d
-		    (loop (- i 1)
-			  (cons (list i (%record-ref object i)) d)))))
-	     ((and (entity? object)
+       (cond ((and (entity? object)
 		   (record? (entity-extra object)))
 	      ((record-entity-describer (entity-extra object)) object))
 	     (else #f))))
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 4d5f4e8a9..45808bbf2 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -214,10 +214,7 @@ USA.
 (add-boot-init!
  (lambda ()
    (register-predicate! predicate? 'predicate)
-   (register-predicate! tag-name? 'tag-name)
-   (register-predicate! %record? '%record)
-   (register-predicate! record? 'record '<= %record?)
-   (cleanup-boot-time-record-predicates!)))
+   (register-predicate! tag-name? 'tag-name)))
 
 ;;; Registration of standard predicates
 (add-boot-init!
@@ -325,8 +322,18 @@ USA.
    (register-predicate! keyword? 'keyword '<= symbol?)
    (register-predicate! lambda-tag? 'lambda-tag)
    (register-predicate! named-structure? 'named-structure)
+   (register-predicate! named-list? 'named-list
+			'<= non-empty-list?
+			'<= named-structure?)
+   (register-predicate! named-vector? 'named-vector
+			'<= vector?
+			'<= named-structure?)
    (register-predicate! population? 'population)
    (register-predicate! promise? 'promise)
+   (register-predicate! %record? '%record)
+   (register-predicate! record? 'record
+			'<= %record?
+			'<= named-structure?)
    (register-predicate! record-type? 'record-type '<= record?)
    (register-predicate! stack-address? 'stack-address)
    (register-predicate! thread-mutex? 'thread-mutex)
@@ -340,7 +347,9 @@ USA.
    (register-predicate! weak-list? 'weak-list)
    (register-predicate! weak-pair? 'weak-pair)
 
-   (register-ustring-predicates!)))
+   (register-ustring-predicates!)
+
+   (cleanup-boot-time-record-predicates!)))
 
 (add-boot-init!
  (lambda ()
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 94d8a125a..7d258e0aa 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -259,120 +259,6 @@ USA.
   (set! boot-time-record-types)
   unspecific)
 
-;;;; Unparser Methods
-
-(define unparse-record)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! unparse-record
-	  (standard-predicate-dispatcher 'unparse-record 2))
-
-    (define-predicate-dispatch-default-handler unparse-record
-      (standard-unparser-method 'record #f))
-
-    (define-predicate-dispatch-handler unparse-record
-      (list any-object? record?)
-      (standard-unparser-method
-       (lambda (record)
-	 (strip-angle-brackets
-	  (%record-type-name (%record-type-descriptor record))))
-       #f))
-
-    (define-predicate-dispatch-handler unparse-record
-      (list any-object? record-type?)
-      (standard-unparser-method 'record-type
-	(lambda (type port)
-	  (write-char #\space port)
-	  (display (%record-type-name type) port))))
-
-    (define-predicate-dispatch-handler unparse-record
-      (list any-object? dispatch-tag?)
-      (simple-unparser-method 'dispatch-tag
-	(lambda (tag)
-	  (list (dispatch-tag-contents tag)))))))
-
-(define set-record-type-unparser-method!
-  (deferred-property-setter
-    (variable-setter set-record-type-unparser-method!)
-    (named-lambda (set-record-type-unparser-method! record-type method)
-      (guarantee unparser-method? method 'set-record-type-unparser-method!)
-      (define-predicate-dispatch-handler unparse-record
-	(list any-object? (record-predicate record-type))
-	method))))
-
-(define record-entity-unparser)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! record-entity-unparser
-	  (standard-predicate-dispatcher 'record-entity-unparser 1))
-
-    (define-predicate-dispatch-default-handler record-entity-unparser
-      (standard-unparser-method 'entity #f))))
-
-(define set-record-type-entity-unparser-method!
-  (deferred-property-setter
-    (variable-setter set-record-type-entity-unparser-method!)
-    (named-lambda (set-record-type-entity-unparser-method! record-type method)
-      (guarantee unparser-method? method
-		 'set-record-type-entity-unparser-method!)
-      (define-predicate-dispatch-handler record-entity-unparser
-	(list (record-predicate record-type))
-	(lambda (record)
-	  (declare (ignore record))
-	  method)))))
-
-(define record-description)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! record-description
-	  (standard-predicate-dispatcher 'record-description 1))
-
-    (define-predicate-dispatch-default-handler record-description
-      (lambda (record)
-	(let loop ((i (fix:- (%record-length record) 1)) (d '()))
-	  (if (fix:< i 0)
-	      d
-	      (loop (fix:- i 1)
-		    (cons (list i (%record-ref record i)) d))))))
-
-    (define-predicate-dispatch-handler record-description
-      (list record?)
-      (lambda (record)
-	(let ((type (%record-type-descriptor record)))
-	  (map (lambda (field-name)
-		 `(,field-name
-		   ,((record-accessor type field-name) record)))
-	       (record-type-field-names type)))))))
-
-(define set-record-type-describer!
-  (deferred-property-setter
-    (variable-setter set-record-type-describer!)
-    (named-lambda (set-record-type-describer! record-type describer)
-      (guarantee unary-procedure? describer 'set-record-type-describer!)
-      (define-predicate-dispatch-handler record-description
-	(list (record-predicate record-type))
-	describer))))
-
-(define record-entity-describer)
-(defer-boot-action 'record/procedures
-  (lambda ()
-    (set! record-entity-describer
-	  (standard-predicate-dispatcher 'record-entity-describer 1))
-
-    (define-predicate-dispatch-default-handler record-entity-describer
-      (lambda (entity)
-	(declare (ignore entity))
-	#f))))
-
-(define set-record-type-entity-describer!
-  (deferred-property-setter
-    (variable-setter set-record-type-entity-describer!)
-    (named-lambda (set-record-type-entity-describer! record-type describer)
-      (guarantee unary-procedure? describer 'set-record-type-entity-describer!)
-      (define-predicate-dispatch-handler record-entity-describer
-	(list (record-predicate record-type))
-	describer))))
-
 ;;;; Constructors
 
 (define (record-constructor record-type #!optional field-names)
@@ -590,6 +476,91 @@ USA.
 (define-guarantee record-type "record type")
 (define-guarantee record "record")
 
+;;;; Printing
+
+(define-unparser-method record?
+  (standard-unparser-method
+   (lambda (record)
+     (strip-angle-brackets
+      (%record-type-name (%record-type-descriptor record))))
+   #f))
+
+(define-unparser-method record-type?
+  (standard-unparser-method 'record-type
+    (lambda (type port)
+      (write-char #\space port)
+      (display (%record-type-name type) port))))
+
+(define-unparser-method dispatch-tag?
+  (simple-unparser-method 'dispatch-tag
+    (lambda (tag)
+      (list (dispatch-tag-contents tag)))))
+
+(define (set-record-type-unparser-method! record-type method)
+  (define-unparser-method (record-predicate record-type)
+    method))
+
+(define-pp-describer %record?
+  (lambda (record)
+    (let loop ((i (fix:- (%record-length record) 1)) (d '()))
+      (if (fix:< i 0)
+	  d
+	  (loop (fix:- i 1)
+		(cons (list i (%record-ref record i)) d))))))
+
+(define-pp-describer record?
+  (lambda (record)
+    (let ((type (%record-type-descriptor record)))
+      (map (lambda (field-name)
+	     `(,field-name
+	       ,((record-accessor type field-name) record)))
+	   (record-type-field-names type)))))
+
+(define (set-record-type-describer! record-type describer)
+  (define-pp-describer (record-predicate record-type)
+    describer))
+
+(define record-entity-unparser)
+(defer-boot-action 'record/procedures
+  (lambda ()
+    (set! record-entity-unparser
+	  (standard-predicate-dispatcher 'record-entity-unparser 1))
+
+    (define-predicate-dispatch-default-handler record-entity-unparser
+      (standard-unparser-method 'entity #f))))
+
+(define set-record-type-entity-unparser-method!
+  (deferred-property-setter
+    (variable-setter set-record-type-entity-unparser-method!)
+    (named-lambda (set-record-type-entity-unparser-method! record-type method)
+      (guarantee unparser-method? method
+		 'set-record-type-entity-unparser-method!)
+      (define-predicate-dispatch-handler record-entity-unparser
+	(list (record-predicate record-type))
+	(lambda (record)
+	  (declare (ignore record))
+	  method)))))
+
+(define record-entity-describer)
+(defer-boot-action 'record/procedures
+  (lambda ()
+    (set! record-entity-describer
+	  (standard-predicate-dispatcher 'record-entity-describer 1))
+
+    (define-predicate-dispatch-default-handler record-entity-describer
+      (lambda (entity)
+	(declare (ignore entity))
+	#f))))
+
+(define set-record-type-entity-describer!
+  (deferred-property-setter
+    (variable-setter set-record-type-entity-describer!)
+    (named-lambda (set-record-type-entity-describer! record-type describer)
+      (guarantee unary-procedure? describer 'set-record-type-entity-describer!)
+      (define-predicate-dispatch-handler record-entity-describer
+	(list (record-predicate record-type))
+	describer))))
+
 ;;;; Runtime support for DEFINE-STRUCTURE
 
 (define (initialize-structure-type-type!)
@@ -678,45 +649,55 @@ USA.
 	    (loop (fix:+ i 1)))))))
 
 (define (structure-tag/unparser-method tag physical-type)
-  (let ((type (tag->structure-type tag physical-type)))
-    (and type
-	 (structure-type/unparser-method type))))
+  (and (structure-type-tag? tag physical-type)
+       (structure-type/unparser-method (tag->structure-type tag))))
 
 (define (structure-tag/entity-unparser-method tag physical-type)
-  (let ((type (tag->structure-type tag physical-type)))
-    (and type
-	 (structure-type/entity-unparser-method type))))
+  (and (structure-type-tag? tag physical-type)
+       (structure-type/entity-unparser-method (tag->structure-type tag))))
 
 (define (named-structure? object)
-  (cond ((record? object) #t)
-	((vector? object)
-	 (and (not (fix:= (vector-length object) 0))
-	      (tag->structure-type (vector-ref object 0) 'VECTOR)))
-	((pair? object) (tag->structure-type (car object) 'LIST))
-	(else #f)))
-
-(define (tag->structure-type tag physical-type)
+  (or (named-list? object)
+      (named-vector? object)
+      (record? object)))
+
+(define (named-list? object)
+  (and (pair? object)
+       (structure-type-tag? (car object) 'list)
+       (list? (cdr object))))
+
+(define (named-vector? object)
+  (and (vector? object)
+       (fix:> (vector-length object) 0)
+       (structure-type-tag? (vector-ref object 0) 'vector)))
+
+(define (structure-type-tag? tag physical-type)
+  (let ((type (tag->structure-type tag)))
+    (and type
+	 (eq? (structure-type/physical-type type) physical-type))))
+
+(define (tag->structure-type tag)
   (if (structure-type? tag)
-      (and (eq? (structure-type/physical-type tag) physical-type)
-	   tag)
+      tag
       (let ((type (named-structure/get-tag-description tag)))
 	(and (structure-type? type)
-	     (eq? (structure-type/physical-type type) physical-type)
 	     type))))
 
-(define (named-structure/description structure)
-  (cond ((record? structure)
-	 (record-description structure))
-	((named-structure? structure)
-	 => (lambda (type)
-	      (let ((accessor (if (pair? structure) list-ref vector-ref)))
-		(map (lambda (field-name index)
-		       `(,field-name ,(accessor structure index)))
-		     (vector->list (structure-type/field-names type))
-		     (vector->list (structure-type/field-indexes type))))))
-	(else
-	 (error:wrong-type-argument structure "named structure"
-				    'NAMED-STRUCTURE/DESCRIPTION))))
+(define-pp-describer named-list?
+  (lambda (pair)
+    (let ((type (tag->structure-type (car pair))))
+      (map (lambda (field-name index)
+	     `(,field-name ,(list-ref pair index)))
+	   (vector->list (structure-type/field-names type))
+	   (vector->list (structure-type/field-indexes type))))))
+
+(define-pp-describer named-vector?
+  (lambda (vector)
+    (let ((type (tag->structure-type (vector-ref vector 0))))
+      (map (lambda (field-name index)
+	     `(,field-name ,(vector-ref vector index)))
+	   (vector->list (structure-type/field-names type))
+	   (vector->list (structure-type/field-indexes type))))))
 
 (define (define-structure/default-value type field-name)
   ((structure-type/default-init type field-name)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5fa235215..942bd60d2 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3749,8 +3749,9 @@ USA.
 	  list-of-unique-symbols?
 	  make-define-structure-type
 	  make-record-type
-	  named-structure/description
+	  named-list?
 	  named-structure?
+	  named-vector?
 	  record-accessor
 	  record-constructor
 	  record-copy
@@ -3773,8 +3774,7 @@ USA.
 	  set-record-type-entity-describer!
 	  set-record-type-entity-unparser-method!
 	  set-record-type-extension!
-	  set-record-type-unparser-method!
-	  unparse-record)
+	  set-record-type-unparser-method!)
   (export (runtime pretty-printer)
 	  record-entity-describer)
   (export (runtime record-slot-access)
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index de06b5776..1d7ef2b0b 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -642,7 +642,8 @@ USA.
 	((uri? record) (unparse/uri record context))
 	((get-param:unparse-with-maximum-readability?)
 	 (*unparse-readable-hash record context))
-	(else (invoke-user-method unparse-record record context))))
+	(else
+	 (*unparse-with-brackets 'record record context #f))))
 
 (define (unparse/uri uri context)
   (*unparse-string "#<" context)