The structure of the tagged data belongs outside of the core code.
(declare (usual-integrations))
\f
-(define (make-compound-tag datum-test operator operands)
- (%make-compound-tag tagging-strategy:optional datum-test operator operands))
-
-(define (%make-compound-tag tagging-strategy datum-test operator operands)
- (tagging-strategy datum-test
- (lambda (predicate tagger)
- (make-tag (cons operator (map tag-name operands))
- predicate tagger operator
- (make-compound-tag-extra operator operands)))))
+(define (make-compound-tag predicate operator operands)
+ (make-tag (cons operator (map tag-name operands))
+ predicate
+ operator
+ (make-compound-tag-extra operator operands)))
(define (tag-is-compound? tag)
(compound-tag-extra? (tag-extra tag)))
(define (parametric-predicate-bindings predicate)
(parametric-tag-bindings (predicate->tag predicate)))
-(define (make-parametric-tag name datum-test template bindings)
- (tagging-strategy:optional datum-test
- (lambda (predicate tagger)
- (make-tag name predicate tagger 'make-predicate-template
- (make-parametric-tag-extra template bindings)))))
+(define (make-parametric-tag name predicate template bindings)
+ (make-tag name predicate 'make-predicate-template
+ (make-parametric-tag-extra template bindings)))
(define (tag-is-parametric? tag)
(parametric-tag-extra? (tag-extra tag)))
(define-integrable (tag-is-bottom? tag) (eq? the-bottom-tag tag))
(define-deferred the-top-tag
- (%make-compound-tag tagging-strategy:never any-object? 'conjoin '()))
+ (make-compound-tag any-object? 'conjoin '()))
(define-deferred the-bottom-tag
- (%make-compound-tag tagging-strategy:never no-object? 'disjoin '()))
+ (make-compound-tag no-object? 'disjoin '()))
(define tag<=-cache)
(define tag<=-overrides)
(named-lambda (register-predicate! predicate name . keylist)
(guarantee keyword-list? keylist 'register-predicate!)
(let ((tag
- (tagging-strategy:never predicate
- (lambda (predicate tagger)
- (make-tag name predicate tagger 'register-predicate!
- (get-keyword-value keylist 'extra)
- (get-keyword-value keylist 'description))))))
+ (make-tag name predicate 'register-predicate!
+ (get-keyword-value keylist 'extra)
+ (get-keyword-value keylist 'description))))
(for-each (lambda (superset)
(set-tag<=! tag (predicate->tag superset)))
(get-keyword-values keylist '<=))
(define (predicate-name predicate)
(tag-name (predicate->tag predicate 'predicate-name)))
-(define (predicate-tagger predicate)
- (tag-tagger (predicate->tag predicate 'predicate-tagger)))
-
(define (predicate-description predicate)
(let ((tag (get-predicate-tag predicate #f)))
(if tag
(predicate-description predicate))
caller))
\f
-(define (make-tag name predicate tagger caller #!optional extra description)
+(define (make-tag name predicate caller #!optional extra description)
(guarantee tag-name? name caller)
(guarantee unary-procedure? predicate caller)
+ (if (predicate? predicate)
+ (error "Can't assign multiple tags to the same predicate:" predicate))
(if (not (default-object? description))
(guarantee string? description caller))
(let ((tag
(%make-tag name
predicate
- tagger
(if (default-object? extra) #f extra)
(if (default-object? description)
(delay (object->description name))
(write object port))))
(define-record-type <tag>
- (%make-tag name predicate tagger extra description subsets supersets)
+ (%make-tag name predicate extra description subsets supersets)
tag?
(name tag-name)
(predicate tag->predicate)
- (tagger tag-tagger)
(extra tag-extra)
(description %tag-description)
(subsets tag-subsets)
(register-predicate! stack-address? 'stack-address)
(register-predicate! thread-mutex? 'thread-mutex)
(register-predicate! undefined-value? 'undefined-value)
- (register-predicate! unicode-char? 'unicode-char '<= bitless-char?)
(register-predicate! unicode-code-point? 'unicode-code-point
'<= index-fixnum?)
(register-predicate! unicode-scalar-value? 'unicode-scalar-value
(%tagged-object-datum object)
object))
-;;;; Tagging strategies
+(define (predicate-tagger predicate)
+ (%tag-tagger (predicate->tag predicate 'predicate-tagger) predicate))
-(define (tagging-strategy:never predicate make-tag)
+(define (tag-tagger tag)
+ (%tag-tagger tag (tag->predicate tag)))
- (define (tagger object #!optional tagger-name)
- (guarantee predicate object tagger-name)
- object)
-
- (define tag
- (make-tag predicate tagger))
-
- tag)
-
-(define (tagging-strategy:optional datum-test make-tag)
-
- (define (predicate object)
- (if (%tagged-object? object)
- (tag<= (%tagged-object-tag object) tag)
- (datum-test object)))
-
- (define (tagger datum #!optional tagger-name)
+(define (%tag-tagger tag predicate)
+ (lambda (datum #!optional tagger-name)
(if (tag<= (object->tag datum) tag)
- datum
+ datum
(begin
- (guarantee datum-test datum tagger-name)
- (%make-tagged-object tag datum))))
-
- (define tag
- (make-tag predicate tagger))
+ (guarantee predicate datum tagger-name)
+ (%make-tagged-object tag datum)))))
- tag)
-\f
(define primitive-tags)
(define primitive-tag-methods)
(add-boot-init!
guarantee-list-of
predicate-description
predicate-name
- predicate-tagger
set-predicate<=!)
(export (runtime)
event:predicate-metadata
tag-description
tag-extra
tag-name
- tag-tagger
tag?))
(define-package (runtime predicate-lattice)
compound-tag-operator
tag-is-compound?)
(export (runtime predicate-lattice)
- %make-compound-tag))
+ make-compound-tag))
(define-package (runtime parametric-predicate)
(files "parametric-predicate")
(parent (runtime))
(export ()
object->datum
- object->predicate)
+ object->predicate
+ predicate-tagger)
(export (runtime)
object->tag
- tagging-strategy:never
- tagging-strategy:optional))
+ tag-tagger))
(define-package (runtime predicate-dispatch)
(files "predicate-dispatch")
projects / mit-scheme.git / commitdiff