[Chicken-hackers] hooks for first-class environments

[Felix]

Hello!


Attached is a patch for customizing variable lookup in "eval". You
can use it like this:


(define my-eval)

(set!-values
 (##sys#eval-global-ref-hook
  ##sys#eval-global-assign-hook
  my-eval)
 ;; use parameter for thread-safety:
 (let ((current-environment (make-parameter '())))
   (define (extend v env)
     (let ((a (cons v unbound)))
       (current-environment (cons a env))
       a))  
   (define unbound (list #f))
   (values
    (lambda (var resolved c)
      (define (ref x)
        (if (eq? unbound x)
            (error "unbound variable" resolved)
            x))
      (let ((env (current-environment)))
        (cond ((not env) c)
              ((assq resolved env) =>
               (lambda (a) (lambda _ (ref (cdr a)))))
              (else 
               (let ((a (extend resolved env)))
                 (lambda _ (ref (cdr a))))))))
    (lambda (var resolved val c)
      (let ((env (current-environment)))
        (cond ((not env) c)
              ((assq resolved env) =>
               (lambda (a) 
                 (lambda (v) (set-cdr! a (val v)))))
              (else 
               (let ((a (extend resolved env)))
                 (lambda (v) (set-cdr! a (val v))))))))
    (lambda (x #!optional e)
      (parameterize ((current-environment e))
        (eval x))))))


;;

(assert (pair? (my-eval '(+ 3 4) `((+ . ,cons)))))
(assert (= 7 (my-eval '(+ 3 4))))
(assert (handle-exceptions _ #t (my-eval '(begin a #f) '()))) ; unbound


I'm not sure whether this deserves a more general customization approach,
so consider it preliminary - still it be useful.


cheers,
felix

commit ae95cdfe32131fecb7b16bc148be8dbfaca98ba8
Author: felix <address@hidden>
Date:   Thu Sep 15 09:54:55 2011 +0200

    added evaluation hooks for variable references

diff --git a/eval.scm b/eval.scm
index 445df6e..0e198a6 100644
--- a/eval.scm
+++ b/eval.scm
@@ -31,7 +31,8 @@
   (hide pds pdss pxss d) 
   (not inline ##sys#repl-read-hook ##sys#repl-print-hook 
        ##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
-       ##sys#syntax-error-hook))
+       ##sys#syntax-error-hook 
+       ##sys#eval-global-ref-hook ##sys#eval-global-assign-hook))
 
 #>
 #ifndef C_INSTALL_EGG_HOME
@@ -179,6 +180,8 @@
 
 (define ##sys#unbound-in-eval #f)
 (define ##sys#eval-debug-level (make-parameter 1))
+(define (##sys#eval-global-ref-hook var rvar c) c)
+(define (##sys#eval-global-assign-hook var rvar val c) c)
 
 (define ##sys#compile-to-closure
   (let ([write write]
@@ -244,12 +247,15 @@
                                     (or (not var)
                                         (not 
(##sys#symbol-has-toplevel-binding? var))))
                            (set! ##sys#unbound-in-eval
-                             (cons (cons var cntr) ##sys#unbound-in-eval)) )
-                         (cond ((not var)
-                                (lambda (v)
-                                  (##sys#error "unbound variable" x)))
-                               (else
-                                (lambda v (##core#inline "C_retrieve" var))))))
+                             (cons (cons (or var x) cntr) 
##sys#unbound-in-eval)) )
+                         (##sys#eval-global-ref-hook
+                          x var
+                          (cond ((not var)
+                                 (lambda (v)
+                                   ;; evaluation in static env and variable 
not found in se
+                                   (##sys#error 'eval "unbound variable" x)))
+                                (else
+                                 (lambda v (##core#inline "C_retrieve" 
var)))))))
                       (else
                        (case i
                          ((0) (lambda (v) 
@@ -348,7 +354,7 @@
                          (let ((var (cadr x)))
                            (receive (i j) (lookup var e se)
                              (let ((val (compile (caddr x) e var tf cntr se)))
-                               (cond [(not i)
+                               (cond ((not i)
                                       (when ##sys#notices-enabled
                                         (and-let* ((a (assq var 
(##sys#current-environment)))
                                                    ((symbol? (cdr a))))
@@ -358,12 +364,20 @@
                                                  (and (not static)
                                                       (##sys#alias-global-hook 
j #t cntr))
                                                  (or (##sys#get j 
'##core#primitive) j))))
-                                        (if (not var) ; static
-                                            (lambda (v)
-                                              (##sys#error 'eval "environment 
is not mutable" evalenv var))
-                                            (lambda (v)
-                                              (##sys#setslot var 0 (##core#app 
val v))) ) ) ]
-                                     [(zero? i) (lambda (v) (##sys#setslot 
(##sys#slot v 0) j (##core#app val v)))]
+                                        (##sys#eval-global-assign-hook
+                                         (cadr x) var val
+                                         (if (not var) ; static
+                                             (lambda (v)
+                                               ;; evaluation in static env and 
variable
+                                               ;; not found in se
+                                               (##sys#error 
+                                                'eval "environment is not 
mutable"
+                                                evalenv (or var x)))
+                                             (lambda (v)
+                                               (##sys#setslot var 0 
(##core#app val v)))))))
+                                     [(zero? i)
+                                      (lambda (v)
+                                        (##sys#setslot (##sys#slot v 0) j 
(##core#app val v)))]
                                      [else
                                       (lambda (v)
                                         (##sys#setslot