From: Joe Marshall Date: Fri, 12 Mar 2010 01:52:24 +0000 (-0800) Subject: Add expressions/equal? X-Git-Tag: 20100708-Gtk~106 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=788b9f57b3b63d11da5b654f235fbd67e88c28ba;p=mit-scheme.git Add expressions/equal? --- diff --git a/src/sf/analyze.scm b/src/sf/analyze.scm index 4595af699..31c50215f 100644 --- a/src/sf/analyze.scm +++ b/src/sf/analyze.scm @@ -64,7 +64,7 @@ USA. (expression/always-false? (conditional/alternative expression)))))) (define-method/always-false? 'CONSTANT - (lambda (expression) + (lambda (expression) (not (constant/value expression)))) (define-method/always-false? 'DECLARATION @@ -148,9 +148,9 @@ USA. (or (expression/never-false? (disjunction/predicate expression)) (expression/boolean? (disjunction/alternative expression)))))) -(define-method/boolean? 'OPEN-BLOCK +(define-method/boolean? 'OPEN-BLOCK (lambda (expression) - (expression/boolean? + (expression/boolean? (last (open-block/actions expression))))) (define-method/boolean? 'PROCEDURE false-procedure) @@ -205,7 +205,7 @@ USA. (expression/make-method-definer can-dup-descend?-dispatch-vector)) (define-integrable (dont-duplicate size expression) - (declare (ignore size expression)) + (declare (ignore size expression)) sf:maximum-duplicate-expression-size) (define-method/can-dup-descend? 'ACCESS dont-duplicate) @@ -599,7 +599,7 @@ USA. (define-method/never-false? 'OPEN-BLOCK (lambda (expression) - (expression/never-false? + (expression/never-false? (last (open-block/actions expression))))) (define-method/never-false? 'PROCEDURE true-procedure) @@ -678,7 +678,7 @@ USA. (define-method/pure-false? 'SEQUENCE (lambda (expression) - (and (for-all? (except-last-pair (sequence/actions expression)) + (and (for-all? (except-last-pair (sequence/actions expression)) expression/effect-free?) ;; unlikely (expression/pure-false? (last (sequence/actions expression)))))) @@ -748,7 +748,7 @@ USA. (define-method/pure-true? 'SEQUENCE (lambda (expression) - (and (for-all? (except-last-pair (sequence/actions expression)) + (and (for-all? (except-last-pair (sequence/actions expression)) expression/effect-free?) (expression/pure-true? (last (sequence/actions expression)))))) @@ -767,4 +767,126 @@ USA. (define (expression/unspecific? expression) (and (constant? expression) (eq? (constant/value expression) unspecific) - (noisy-test sf:enable-true-unspecific? "Enable true unspecific"))) \ No newline at end of file + (noisy-test sf:enable-true-unspecific? "Enable true unspecific"))) + +;;; EXPRESSIONS/EQUAL? +;; +;; Returns #t if two expressions always compute the same value. +;; This is not meant to be a heroic attempt to prove extrinsic equality, +;; but rather a simple check to see if we have essentially the same +;; form. Returning false is a safe default. + +(declare (integrate-operator expressions/equal?)) +(define (expressions/equal? left right) + ((expression/method equal?-dispatch-vector left) left right)) + +(define equal?-dispatch-vector + (expression/make-dispatch-vector)) + +(define define-method/equal? + (expression/make-method-definer equal?-dispatch-vector)) + +(define-method/equal? 'ACCESS + (lambda (left right) + (and (access? right) + (eq? (access/name left) (access/name right)) + (expressions/equal? (access/environment left) (access/environment right))))) + +(define-method/equal? 'ASSIGNMENT + (lambda (left right) + (and (assignment? right) + (eq? (assignment/variable left) (assignment/variable right)) + (expressions/equal? (assignment/value left) (assignment/value right))))) + +(define-method/equal? 'COMBINATION + (lambda (left right) + (and (combination? right) + (let scan ((left-args (combination/operands left)) + (right-args (combination/operands right))) + (cond ((pair? left-args) (and (pair? right-args) + (expressions/equal? (car left-args) (car right-args)) + (scan (cdr left-args) (cdr right-args)))) + ((null? left-args) (and (null? right-args) + (expressions/equal? (combination/operator left) + (combination/operator right)))) + (else #f)))))) + +(define-method/equal? 'CONDITIONAL + (lambda (left right) + (and (conditional? right) + (or (and (expressions/equal? (conditional/predicate left) (conditional/predicate right)) + (or (expression/always-false? (conditional/predicate left)) + (expressions/equal? (conditional/consequent left) (conditional/consequent right))) + (or (expression/never-false? (conditional/predicate left)) + (expressions/equal? (conditional/alternative left) (conditional/alternative right)))) + (and (expression/pure-false? (conditional/predicate left)) + (expression/pure-false? (conditional/predicate right)) + (expressions/equal? (conditional/alternative left) (conditional/alternative right))) + (and (expression/pure-true? (conditional/predicate left)) + (expression/pure-true? (conditional/predicate right)) + (expressions/equal? (conditional/consequent left) (conditional/consequent right))) + (and (expression/pure-false? (conditional/predicate left)) + (expression/pure-true? (conditional/predicate right)) + (expressions/equal? (conditional/alternative left) (conditional/consequent right))) + (and (expression/pure-true? (conditional/predicate left)) + (expression/pure-false? (conditional/predicate right)) + (expressions/equal? (conditional/consequent left) (conditional/alternative right))))))) + +(define-method/equal? 'CONSTANT + (lambda (left right) + (and (constant? right) + (eq? (constant/value left) (constant/value right))))) + +(define-method/equal? 'DECLARATION + (lambda (left right) + #f)) + +(define-method/equal? 'DELAY + (lambda (left right) + #f)) + +(define-method/equal? 'DISJUNCTION + (lambda (left right) + (and (disjunction? right) + (expressions/equal? (disjunction/predicate left) + (disjunction/predicate right)) + (expressions/equal? (disjunction/alternative left) + (disjunction/alternative right))))) + +(define-method/equal? 'OPEN-BLOCK + (lambda (left right) + #f)) + +(define-method/equal? 'PROCEDURE + (lambda (left right) + #f)) + +(define-method/equal? 'QUOTATION + (lambda (left right) + #f)) + +(define-method/equal? 'REFERENCE + (lambda (left right) + (and (reference? right) + (eq? (reference/variable left) + (reference/variable right))))) + +(define-method/equal? 'SEQUENCE + (lambda (left right) + (and (sequence? right) + (let scan ((left-args (sequence/actions left)) + (right-args (sequence/actions right))) + (cond ((pair? left-args) + (and (pair? right-args) + (if (eq? (car left-args) open-block/value-marker) + (eq? (car right-args) open-block/value-marker) + (and (not (eq? (car right-args) open-block/value-marker)) + (expressions/equal? (car left-args) + (car right-args)))) + (scan (cdr left-args) (cdr right-args)))) + ((null? left-args) (null? right-args)) + (else #f)))))) + +(define-method/equal? 'THE-ENVIRONMENT + (lambda (left right) + (the-environment? right))) \ No newline at end of file