It's still not quite right, but it is at least somewhat closer.
(declare (usual-integrations))
\f
(define (make-compound-tag datum-test operator operands)
- (make-tag (cons operator (map tag-name operands))
- datum-test
- predicate-tagging-strategy:optional
- operator
- (make-compound-tag-extra 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 (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 tagging-strategy template bindings)
- (make-tag name
- datum-test
- tagging-strategy
- 'make-predicate-template
- (make-parametric-tag-extra template bindings)))
+(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 (tag-is-parametric? tag)
(parametric-tag-extra? (tag-extra tag)))
\f
;;;; Templates
-(define (make-predicate-template name pattern tagging-strategy make-data-test)
+(define (make-predicate-template name pattern make-data-test)
(guarantee template-pattern? pattern 'make-predicate-template)
(letrec*
((instantiator
- (make-instantiator name pattern make-data-test tagging-strategy
- (lambda () template)))
+ (make-instantiator name pattern make-data-test (lambda () template)))
(template
(%make-predicate-template name
pattern
(instantiator template-instantiator)
(predicate predicate-template-predicate))
-(define (make-instantiator name pattern make-data-test tagging-strategy
- get-template)
+(define (make-instantiator name pattern make-data-test get-template)
(lambda (patterned-tags caller)
(letrec ((tag
(make-parametric-tag
patterned-tags
tag->predicate
caller))
- tagging-strategy
(get-template)
(match-template-pattern pattern
patterned-tags
(predicate-template-constructor
(make-predicate-template 'is-list-of
'((? elt-predicate))
- predicate-tagging-strategy:optional
(lambda (elt-predicate)
(lambda (object)
(list-of-type? object elt-predicate))))))
(predicate-template-constructor
(make-predicate-template 'is-non-empty-list-of
'((? elt-predicate))
- predicate-tagging-strategy:optional
(lambda (elt-predicate)
(lambda (object)
(and (pair? object)
(predicate-template-constructor
(make-predicate-template 'is-non-empty-list-of
'((? car-predicate) (? cdr-predicate))
- predicate-tagging-strategy:optional
(lambda (car-predicate cdr-predicate)
(lambda (object)
(and (pair? object)
(define-integrable (tag-is-bottom? tag) (eq? the-bottom-tag tag))
(define-deferred the-top-tag
- (make-compound-tag any-object? 'conjoin '()))
+ (%make-compound-tag tagging-strategy:never any-object? 'conjoin '()))
(define-deferred the-bottom-tag
- (make-compound-tag no-object? 'disjoin '()))
+ (%make-compound-tag tagging-strategy:never no-object? 'disjoin '()))
(define tag<=-cache)
(define tag<=-overrides)
(named-lambda (register-predicate! predicate name . keylist)
(guarantee keyword-list? keylist 'register-predicate!)
(let ((tag
- (make-tag name
- predicate
- predicate-tagging-strategy:never
- 'register-predicate!
- (get-keyword-value keylist 'extra)
- (get-keyword-value keylist 'description))))
+ (tagging-strategy:never predicate
+ (lambda (predicate tagger)
+ (make-tag name predicate tagger '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-tagger predicate)
(tag-tagger (predicate->tag predicate 'predicate-tagger)))
-(define (predicate-untagger predicate)
- (tag-untagger (predicate->tag predicate 'predicate-untagger)))
-
-(define (predicate-tagging-strategy predicate)
- (tag-tagging-strategy (predicate->tag predicate 'predicate-tagging-strategy)))
-
(define (predicate-description predicate)
(let ((tag (get-predicate-tag predicate #f)))
(if tag
(predicate-description predicate))
caller))
\f
-(define (make-tag name datum-test tagging-strategy caller
- #!optional extra description)
+(define (make-tag name predicate tagger caller #!optional extra description)
(guarantee tag-name? name caller)
- (guarantee unary-procedure? datum-test caller)
+ (guarantee unary-procedure? predicate caller)
(if (not (default-object? description))
(guarantee string? description caller))
- (tagging-strategy name datum-test
- (lambda (predicate tagger untagger)
- (let ((tag
- (%make-tag name
- predicate
- tagger
- untagger
- (if (default-object? extra) #f extra)
- (if (default-object? description) #f description)
- tagging-strategy
- (make-key-weak-eq-hash-table)
- (make-key-weak-eq-hash-table))))
- (set-predicate-tag! predicate tag)
- tag))))
+ (let ((tag
+ (%make-tag name
+ predicate
+ tagger
+ (if (default-object? extra) #f extra)
+ (if (default-object? description)
+ (delay (object->description name))
+ (delay description))
+ (make-key-weak-eq-hash-table)
+ (make-key-weak-eq-hash-table))))
+ (set-predicate-tag! predicate tag)
+ tag))
(define (tag-name? object)
(or (symbol? object)
(tag-name? elt)))
(cdr object)))))
+(define (object->description object)
+ (call-with-output-string
+ (lambda (port)
+ (write object port))))
+
(define-record-type <tag>
- (%make-tag name predicate tagger untagger extra description
- tagging-strategy subsets supersets)
+ (%make-tag name predicate tagger extra description subsets supersets)
tag?
(name tag-name)
(predicate tag->predicate)
(tagger tag-tagger)
- (untagger tag-untagger)
(extra tag-extra)
(description %tag-description)
- (tagging-strategy tag-tagging-strategy)
(subsets tag-subsets)
(supersets tag-supersets))
(list (tag-name tag)))))
(define (tag-description tag)
- (or (%tag-description tag)
- (object->description (tag-name tag))))
-
-(define (object->description object)
- (call-with-output-string
- (lambda (port)
- (write object port))))
+ (force (%tag-description tag)))
(define (get-tag-subsets tag)
(hash-table-keys (tag-subsets tag)))
\f
;;;; Tagging strategies
-(define (predicate-tagging-strategy:never name predicate make-tag)
- (declare (ignore name))
+(define (tagging-strategy:never predicate make-tag)
(define (tagger object #!optional tagger-name)
(guarantee predicate object tagger-name)
object)
- (define (untagger object #!optional untagger-name)
- (guarantee predicate object untagger-name)
- object)
-
- (define tag
- (make-tag predicate tagger untagger))
-
- tag)
-
-(define (predicate-tagging-strategy:always name datum-test make-tag)
-
- (define (predicate object)
- (and (tagged-object? object)
- (tag<= (%tagged-object-tag object) tag)
- (datum-test (%tagged-object-datum object))))
-
- (define (tagger datum #!optional tagger-name)
- (if (not (datum-test datum))
- (error:wrong-type-argument datum (string "datum for " name)
- tagger-name))
- (%make-tagged-object tag datum))
-
- (define (untagger object #!optional untagger-name)
- (guarantee predicate object untagger-name)
- (%tagged-object-datum object))
-
(define tag
- (make-tag predicate tagger untagger))
+ (make-tag predicate tagger))
tag)
-(define (predicate-tagging-strategy:optional name datum-test make-tag)
+(define (tagging-strategy:optional datum-test make-tag)
(define (predicate object)
(or (tagged-object-test object)
(datum-test (%tagged-object-datum object))))
(define (tagger datum #!optional tagger-name)
- (if (not (datum-test datum))
- (error:wrong-type-argument datum (string "datum for " name)
- tagger-name))
+ (guarantee datum-test datum tagger-name)
(if (tag<= (object->tag datum) tag)
datum
(%make-tagged-object tag datum)))
- (define (untagger object #!optional untagger-name)
- (cond ((tagged-object-test object) (%tagged-object-datum object))
- ((datum-test object) object)
- (else (error:not-a predicate object untagger-name))))
-
(define tag
- (make-tag predicate tagger untagger))
+ (make-tag predicate tagger))
tag)
\f
predicate-description
predicate-name
predicate-tagger
- predicate-tagging-strategy
- predicate-untagger
set-predicate<=!)
(export (runtime)
event:predicate-metadata
tag-extra
tag-name
tag-tagger
- tag-tagging-strategy
- tag-untagger
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")
(files "predicate-tagging")
(parent (runtime))
(export ()
- predicate-tagging-strategy:always
- predicate-tagging-strategy:never
- predicate-tagging-strategy:optional
object->datum
object->predicate)
(export (runtime)
object->tag
tagged-object-datum
- tagged-object-tag))
+ tagged-object-tag
+ tagging-strategy:never
+ tagging-strategy:optional))
(define-package (runtime predicate-dispatch)
(files "predicate-dispatch")
(test-tagging (conjoin number? string?) '() '(41 #t "41" 'foo))))
(define (test-tagging predicate data non-data)
- (let ((tagger (predicate-tagger predicate))
- (untagger (predicate-untagger predicate))
- (tagging-strategy (predicate-tagging-strategy predicate)))
- (for-each
- (lambda (datum)
- (let ((object (tagger datum)))
- (assert-true (predicate object))
- (assert-eq datum (untagger object))
- (cond ((eqv? tagging-strategy predicate-tagging-strategy:never)
- (assert-eq datum object))
- ((eqv? tagging-strategy predicate-tagging-strategy:always)
- (assert-!eq datum object))
- (else
- (if (predicate<= (object->predicate datum) predicate)
- (assert-eq datum object)
- (assert-!eq datum object))))))
- data)
+ (let ((tagger (predicate-tagger predicate)))
+ (for-each (lambda (datum)
+ (let ((object (tagger datum)))
+ (assert-true (predicate object))
+ (assert-eq datum (object->datum object))))
+ data)
(for-each (lambda (non-datum)
(assert-type-error (lambda () (tagger non-datum))))
non-data)))
\ No newline at end of file
(declare (usual-integrations))
\f
(define (make-template name pattern)
- (make-predicate-template name pattern
- predicate-tagging-strategy:always
- (lambda args args any-object?)))
+ (make-predicate-template name pattern (lambda args args any-object?)))
(define-test 'parametric-predicate-one-parameter
(lambda ()
(test-tagging string? '("41") '(foo))))
(define (test-tagging predicate data non-data)
- (let ((tagger (predicate-tagger predicate))
- (untagger (predicate-untagger predicate))
- (tagging-strategy (predicate-tagging-strategy predicate)))
- (for-each
- (lambda (datum)
- (let ((object (tagger datum)))
- (assert-true (predicate object))
- (assert-eq datum (untagger object))
- (cond ((eqv? tagging-strategy predicate-tagging-strategy:never)
- (assert-eq datum object))
- ((eqv? tagging-strategy predicate-tagging-strategy:always)
- (assert-!eq datum object))
- (else
- (if (predicate<= (object->predicate datum) predicate)
- (assert-eq datum object)
- (assert-!eq datum object))))))
- data)
+ (let ((tagger (predicate-tagger predicate)))
+ (for-each (lambda (datum)
+ (let ((object (tagger datum)))
+ (assert-true (predicate object))
+ (assert-eq datum (object->datum object))))
+ data)
(for-each (lambda (non-datum)
(assert-type-error (lambda () (tagger non-datum))))
non-data)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff