diff options
-rw-r--r-- | module/analyzer/value-sets.scm | 80 | ||||
-rw-r--r-- | test-suite/tests/analyzer.test | 33 |
2 files changed, 95 insertions, 18 deletions
diff --git a/module/analyzer/value-sets.scm b/module/analyzer/value-sets.scm index 3c23d4be3..34545360f 100644 --- a/module/analyzer/value-sets.scm +++ b/module/analyzer/value-sets.scm @@ -1,5 +1,6 @@ (define-module (analyzer value-sets) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-1) #:export (value-set value-set-type make-value-set value-set? value-set-values set-value-set-values! @@ -7,8 +8,13 @@ value-set-nothing value-set-anything value-set-can-be-anything? value-set-has-values? + value-set-has-value? value-set-has-property? value-set-with-values - value-set-value-satisfying)) + value-set-value-satisfying + + value-set-union! + value-set-add-value! + value-set-add-property!)) #| @@ -48,7 +54,7 @@ (values value-set-values set-value-set-values!) (properties value-set-properties set-value-set-properties!)) -; convenience constructors +;; convenience constructors (define (value-set-anything) (value-set '() '((anything)))) (define (value-set-nothing) @@ -56,7 +62,7 @@ (define (value-set-with-values . vals) (value-set vals '())) -; and predicates +;; and predicates (define (value-set-has-values? vs) (or (not (null? (value-set-values vs))) (not (null? (value-set-properties vs))))) @@ -67,37 +73,77 @@ ((eq? (caar props) 'anything) #t) (else (loop (cdr props)))))) -; and a selector +(define (value-set-has-value? vs v) + (memq v (value-set-values vs))) + +(define (value-set-has-property? vs p) + (assq p (value-set-properties vs))) + +;; and a selector (define (value-set-value-satisfying vs pred) (let loop ((vals (value-set-values vs))) (cond ((null? vals) #f) ((pred (car vals)) (car vals)) (else (loop (cdr vals)))))) +;; and three modifiers. these are really three cases of the same thing - +;; a general case and two special ones. they are the basic operation on +;; value sets. + +;; this function sets t to the union of t and x. +;; it uses a recursive merge if one of the values is a pair. +(define (value-set-union! t x) + (cond ((value-set-can-be-anything? x) + (set-value-set-values! t '()) + (set-value-set-properties! t '((anything)))) + (else + (for-each (value-set-values x) + (lambda (v) (value-set-add-value! t v))) + (for-each (value-set-properties x) + (lambda (p) (value-set-add-property! t p)))))) + +(define (value-set-add-value! t v) + (if (pair? v) + (let ((old-pair (value-set-value-satisfying t pair?))) + (if old-pair + (begin (value-set-union! (car old-pair) (car v)) + (value-set-union! (cdr old-pair) (cdr v))) + (set-value-set-values! t (cons v (value-set-values t))))) + (if (not (memv v (value-set-values t))) + (set-value-set-values! t (cons v (value-set-values t)))))) + +(define (value-set-add-property! t p) + (cond ((equal? p '(anything)) + (set-value-set-properties! t '((anything))) + (set-value-set-values! t '())) + ((equal? p '(number?)) + (set-value-set-properties! t '((number?)))) + (else + (error "Don't know how to add property" p)))) + (define-record-type primitive-procedure-type ;; this type holds the value-set version of a primitive procedure (primitive-procedure evaluator) primitive-procedure? (evaluator primitive-procedure-evaluator)) -(define (vs-cons a b) - (values - (value-set (list (cons a b)) - '()) - '())) +;; all procedures take an extra first argument, the "target", which is +;; the value set of their return value. +(define (vs-cons t a b) + (value-set-add-value! t + (cons a b))) -(define (vs-car p) +(define (vs-car t p) (if (value-set-can-be-anything? p) - (value-set-anything) + (value-set-union! t (value-set-anything)) (let ((pair (value-set-value-satisfying p pair?))) (if pair - (car pair) - (value-set-nothing))))) + (value-set-union! t (car pair)))))) -(define (vs-cdr p) +(define (vs-cdr t p) (if (value-set-can-be-anything? p) - (value-set-anything) + (value-set-union! t (value-set-anything)) (let ((pair (value-set-value-satisfying p pair?))) (if pair - (car pair) - (value-set-nothing))))) + (value-set-union! t (car pair)))))) + diff --git a/test-suite/tests/analyzer.test b/test-suite/tests/analyzer.test index d4bd8a072..824cbee74 100644 --- a/test-suite/tests/analyzer.test +++ b/test-suite/tests/analyzer.test @@ -49,11 +49,13 @@ (define anything (value-set-anything)) (define simple (value-set-with-values 1 2 3)) +(define (true? x) (not (not x))) + (pass-if "value-set-can-be-anything?" (value-set-can-be-anything? anything)) (pass-if "value-set-value-satisfying" - (not (not (value-set-value-satisfying simple number?)))) + (true? (value-set-value-satisfying simple number?))) (pass-if "value-set-value-satisfying" (not (value-set-value-satisfying nothing number?))) @@ -64,3 +66,32 @@ (value-set-has-values? anything)) (pass-if "value-set-has-values?" (value-set-has-values? simple)) + +(pass-if "value-set-has-value?" + (true? (value-set-has-value? simple 3))) + +(pass-if "value-set-has-value?" + (not (value-set-has-value? nothing 4))) + +(pass-if "value-set-has-property?" + (true? (value-set-has-property? anything 'anything))) +(pass-if "value-set-has-property?" + (not (value-set-has-property? simple 'anything))) + +(pass-if "union value 4 onto other numbers" + (begin (value-set-add-value! simple 4) + (true? (value-set-has-value? simple 4)))) + +(pass-if "add property (number?)" + (begin (value-set-add-property! nothing '(number?)) + (true? (value-set-has-property? nothing 'number?)))) + +(pass-if "add property (anything), no other properties" + (begin (value-set-add-property! nothing '(anything)) + (not (value-set-has-property? nothing 'number?)))) + +(pass-if "add property (anything), no values" + (begin (value-set-add-property! simple '(anything)) + (not (value-set-has-value? simple 3)))) + + |