Relocated environment functions

scheme/eval.sld

@@ -40,7 +40,7 @@
 (define (create-environment vars vals)
   ;(write `(DEBUG vars ,vars))
   ;(write `(DEBUG vals ,vals))
-  (extend-environment vars vals *global-environment*)) ;; TODO: setup?
+  (env:extend-environment vars vals *global-environment*)) ;; TODO: setup?
 
 (define (eval exp . env)
   (if (null? env)
@@ -122,85 +122,6 @@
   (tagged-list? macro-tag exp))
 
 ;; Environments
-(define (enclosing-environment env) (cdr env))
-(define (first-frame env) (car env))
-(define the-empty-environment '())
-
-(define (make-frame variables values)
-  (cons variables values))
-(define (frame-variables frame) (car frame))
-(define (frame-values frame) (cdr frame))
-(define (add-binding-to-frame! var val frame)
-  (set-car! frame (cons var (car frame)))
-  (set-cdr! frame (cons val (cdr frame))))
-
-(define (extend-environment vars vals base-env)
-  (if (= (length vars) (length vals))
-      (cons (make-frame vars vals) base-env)
-      (if (< (length vars) (length vals))
-          (error "Too many arguments supplied" vars vals)
-          (error "Too few arguments supplied" vars vals))))
-
-(define (lookup-variable-value var env)
-  (_lookup-variable-value var env 
-    (lambda ()
-      (error "Unbound variable" var))))
-
-(define (_lookup-variable-value var env not-found)
-  (define (env-loop env)
-    (define (scan vars vals)
-      (cond ((null? vars)
-             (env-loop (enclosing-environment env)))
-            ((eq? var (car vars))
-             (cond-expand
-               (cyclone
-                 (Cyc-get-cvar (car vals)))
-               (else 
-                 (car vals))))
-            (else (scan (cdr vars) (cdr vals)))))
-    (if (eq? env the-empty-environment)
-        (not-found)
-        (let ((frame (first-frame env)))
-          (scan (frame-variables frame)
-                (frame-values frame)))))
-  (env-loop env))
-
-(define (set-variable-value! var val env)
-  (define (env-loop env)
-    (define (scan vars vals)
-      (cond ((null? vars)
-             (env-loop (enclosing-environment env)))
-            ((eq? var (car vars))
-             (cond-expand
-               (cyclone
-                 (if (Cyc-cvar? (car vals))
-                   (Cyc-set-cvar! (car vals) val)
-                   (set-car! vals val)))
-               (else
-                 (set-car! vals val))))
-            (else (scan (cdr vars) (cdr vals)))))
-    (if (eq? env the-empty-environment)
-        (error "Unbound variable -- SET!" var)
-        (let ((frame (first-frame env)))
-          (scan (frame-variables frame)
-                (frame-values frame)))))
-  (env-loop env))
-
-(define (define-variable! var val env)
-  (let ((frame (first-frame env)))
-    (define (scan vars vals)
-      (cond ((null? vars)
-             (add-binding-to-frame! var val frame))
-            ((eq? var (car vars))
-             ;; TODO: update compiled var
-             ;; cond-expand
-             ;;  if cvar
-             ;;     set-cvar
-             (set-car! vals val))
-            (else (scan (cdr vars) (cdr vals)))))
-    (scan (frame-variables frame)
-          (frame-values frame))))
-
 (define (primitive-procedure? proc)
   (tagged-list? 'primitive proc))
 
@@ -348,13 +269,13 @@
 
 (define (setup-environment)
   (let ((initial-env
-         (extend-environment (primitive-procedure-names)
+         (env:extend-environment (primitive-procedure-names)
                              (primitive-procedure-objects)
-                             the-empty-environment)))
+                             env:the-empty-environment)))
     (cond-expand
       (cyclone
         ;; Also include compiled variables
-        (extend-environment
+        (env:extend-environment
           (map (lambda (v) (car v)) (Cyc-global-vars))
           (map (lambda (v) (cdr v)) (Cyc-global-vars))
           initial-env))
@@ -400,20 +321,20 @@
     (lambda (env) qval)))
 
 (define (analyze-variable exp)
-  (lambda (env) (lookup-variable-value exp env)))
+  (lambda (env) (env:lookup-variable-value exp env)))
 
 (define (analyze-assignment exp a-env)
   (let ((var (assignment-variable exp))
         (vproc (analyze (assignment-value exp) a-env)))
     (lambda (env)
-      (set-variable-value! var (vproc env) env)
+      (env:set-variable-value! var (vproc env) env)
       'ok)))
 
 (define (analyze-definition exp a-env)
   (let ((var (definition-variable exp))
         (vproc (analyze (definition-value exp) a-env)))
     (lambda (env)
-      (define-variable! var (vproc env) env)
+      (env:define-variable! var (vproc env) env)
       'ok)))
 
 (define (analyze-if exp a-env)
@@ -451,7 +372,7 @@
 
   (let* ((op (operator exp))
          (var (if (symbol? op)
-                  (_lookup-variable-value op a-env
+                  (env:_lookup-variable-value op a-env
                     (lambda () #f)) ; Not found
                   #f))
          (expand 
@@ -502,7 +423,7 @@
          (apply-primitive-procedure proc args))
         ((compound-procedure? proc)
          ((procedure-body proc)
-          (extend-environment (procedure-parameters proc)
+          (env:extend-environment (procedure-parameters proc)
                               args
                               (procedure-environment proc))))
         ((procedure? proc)
@@ -536,7 +457,7 @@
 ;;; TODO:
 ;;        ;((compound-procedure? proc)
 ;;        ; ((procedure-body proc)
-;;        ;  (extend-environment (procedure-parameters proc)
+;;        ;  (env:extend-environment (procedure-parameters proc)
 ;;        ;                      args
 ;;        ;                      (procedure-environment proc))))
 ;        (else