From b3e6401cdba421f7fdfce774a853263371e21090 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 2 Dec 2018 02:45:35 +0000
Subject: [PATCH] Rework vector tag printer methods so they work again.
XXX Needs tests, but these are a pain to construct...
---
src/compiler/base/object.scm | 56 ++++++++++++++++++++++--------------
1 file changed, 34 insertions(+), 22 deletions(-)
diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 34f84b607..949493454 100644
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -29,11 +29,13 @@ USA.
(declare (usual-integrations))
(define-structure (vector-tag
- (constructor %make-vector-tag (parent name index noop)))
+ (constructor %make-vector-tag
+ (parent name index predicate noop)))
(parent false read-only true)
(name false read-only true)
(index false read-only true)
(description false)
+ (predicate false read-only true)
(method-alist '())
;; This property was stored in the method alist, but it is used so
@@ -42,30 +44,40 @@ USA.
)
(define make-vector-tag
- (let ((root-tag (%make-vector-tag false 'OBJECT false false)))
- (define-print-method (lambda (object)
- (and (vector? object)
- (fix:> (vector-length object) 0)
- (eq? root-tag (vector-ref object 0))))
- (standard-print-method
- (lambda (object)
- (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
+ (let ()
+ (define (root-tagged-vector? object)
+ (and (vector? object)
+ (fix:> (vector-length object) 0)
+ (eq? root-tag (vector-ref object 0))))
+ (define root-tag
+ (%make-vector-tag false 'OBJECT false root-tagged-vector? false))
+ (register-predicate! root-tagged-vector? 'root-tagged-vector?
+ '<= vector?)
(named-lambda (make-vector-tag parent name enumeration)
- (%make-vector-tag (or parent root-tag)
- name
- (and enumeration
- (enumeration/name->index enumeration
- name))
- ;; Propagate this downward at construction time
- ;; to avoid having to crawl upward at use time.
- (and parent (vector-tag-noop parent))))))
+ (define (predicate object)
+ (and (vector? object)
+ (fix:> (vector-length object) 0)
+ (eq? tag (vector-ref object 0))))
+ (define tag
+ (%make-vector-tag (or parent root-tag)
+ name
+ (and enumeration
+ (enumeration/name->index enumeration
+ name))
+ predicate
+ ;; Propagate this downward at construction time
+ ;; to avoid having to crawl upward at use time.
+ (and parent (vector-tag-noop parent))))
+ (register-predicate! predicate (symbol name '?)
+ '<= (vector-tag-predicate (or parent root-tag)))
+ (define-print-method predicate
+ (standard-print-method
+ (lambda (object)
+ (string "LIAR:" (vector-tag-name (tagged-vector/tag object))))))
+ tag)))
(define (define-vector-tag-unparser tag unparser)
- (define-print-method (lambda (object)
- (and (vector? object)
- (fix:> (vector-length object) 0)
- (eq? tag (vector-ref object 0))))
- unparser)
+ (define-print-method (vector-tag-predicate tag) unparser)
(vector-tag-name tag))
(define (vector-tag-put! tag key value)
--
2.25.1