summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/analyzer/value-sets.scm80
-rw-r--r--test-suite/tests/analyzer.test33
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))))
+
+