diff options
Diffstat (limited to 'vikalpa.scm')
| -rw-r--r-- | vikalpa.scm | 34 |
1 files changed, 23 insertions, 11 deletions
diff --git a/vikalpa.scm b/vikalpa.scm index 78b751a..dab81b2 100644 --- a/vikalpa.scm +++ b/vikalpa.scm @@ -233,11 +233,7 @@ ;; (expression? x) -> boolean? (define (expression? expr) - (cond ((expr-quoted? expr) - (or (exact-integer? (expr-unquote expr)) - (boolean? (expr-unquote expr)) - (symbol? (expr-unquote expr)) - (null? (expr-unquote expr)))) + (cond ((expr-quoted? expr) #t) ((if-form? expr) (and (expression? (if-form-test expr)) (expression? (if-form-then expr)) @@ -668,6 +664,7 @@ (and (pair? x) (eq? 'error (car x)))) + (define (rewrite/eval expr sys) (let eval ((expr expr)) (cond @@ -676,14 +673,29 @@ ((app-form? expr) (let ((args (map eval (app-form-args expr))) (name (app-form-name expr))) + (define (guard-ok? vars form g) + (let ((result (eval (apply-rule '() + (rule vars '() form g) + `(,name ,@args) + '())))) + (if (error? result) + result + (expr-unquote result)))) (cond ((find error? args) => identity) - (else - (eval (rewrite1 sys - `(,name ,@args) - (lambda args - (cons* 'error 'rewrite name args)) - `(rewrite () ,name))))))) + ((lookup name sys) + => (lambda (f) + (let ((gs (get-guards f)) + (vars (get-variables f)) + (form (defined-function-app-form f))) + (if (every (lambda (g) (guard-ok? vars form g)) gs) + (eval (rewrite1 sys + `(,name ,@args) + (lambda args + (cons* 'error 'rewrite name args)) + `(rewrite () ,name))) + `(error guard-error (,name ,@args) (and ,@gs)))))) + (else `(error function not-found))))) ((if-form? expr) (let ((test (eval (if-form-test expr)))) (if (error? test) |