;; A scimple scheme and lisp interpreter by S. Ducasse
;; ducasse@iam.unibe.ch
;; Dec 2003




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Closure representation for Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define magic-closure-tag '*closure*)
(define (%closure? clos)   
  (and (pair? clos) 
       (eq? (car clos) magic-closure-tag)))

(define (%make-closure args body env)
  (list magic-closure-tag args body env))

(define (%closure-args clos)
  (cadr clos))
(define (%closure-body clos)
  (caddr clos))
(define (%closure-env clos)
  (cadddr clos))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; primitive representation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define magic-primitive-tag '*primitive*)

(define (%primitive? proc)   
  (and (pair? proc) 
       (eq? (car proc) magic-primitive-tag))) 

(define (%make-primitive symbol function)
  (list magic-primitive-tag symbol function))

(define (%primitive-function prim)
  (caddr prim))
(define (%primitive-symbol prim)
  (cadr prim))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;binding, binding table, and environment
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define %top-level-env '())

(define %primitive-symbols
  '(+ - * / = < > not equal? null? cons car cdr))

(define %primitive-functions
  (list + - * / = < > not equal? null? cons car cdr))

(define (%make-binding id val)
  ;; creates a binding for a table binding element
  (cons id val))

(define (%initialize-top-level-env)
  (set! %top-level-env 
        (%extend-env %primitive-symbols 
                     (map %make-primitive %primitive-symbols %primitive-functions) 
                     %top-level-env)))

(define (%extend-env lids lvals env)
  ;; add a new a binding table in front of the env
  (cons (map %make-binding lids lvals) env))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; an environment to test environment functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *verbose* #f)
(define %test-env '())
(define (%initialize-test-env)
  (%initialize-top-level-env)
  (set! %test-env (%extend-env '(a b c z) '(1 2 3 26) %top-level-env)))
(%initialize-test-env)

(define-macro %%test 
  (lambda (expr res)
  (quasiquote
   (begin
     (display "expr: ")
     (display ,expr)
     (newline)
     (display "res: ")
     (display ,res) 
     (newline)
     (equal? ,expr ,res)))))

(define-macro %%test 
  (lambda (expr res)
  (quasiquote (equal? ,expr ,res))))

(%%test (car %test-env) '((a . 1) (b . 2) (c . 3) (z . 26)))
  
(%%test (%extend-env '(a z) '(100 200) %test-env)
        (cons '((a . 100) (z . 200)) %test-env))
        
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; binding manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (%binding id env)
  ;; symbol * env -> binding
  ;; return the first binding whose car is id.
  ;; return #f when no binding is found
  (if (null? env)
      #f
      (or (assq id (car env)) (%binding id (cdr env)))))
   
(%%test (%binding 'a %test-env) '(a . 1))
(equal? (%binding 'a '(((a . 200) (a . 1) (b . 2) (c . 3) (z . 26)))) '(a . 200))
(equal? (%binding 'e '(((a . 200) (a . 1) (b . 2) (c . 3) (z . 26)))) #f)
(equal? (%binding 'a '(((a . 200) (b1 . 3)) ((a . 1) (b . 2) (c . 3) (z . 26)))) '(a . 200))



(define (%lookup id env)
  ;; return the val of id in env
  ;; error if id is not defined in env
  
  (let ((binding (%binding id env)))
    (if (boolean? binding)
        (error "Error: unknown identifier " id)
        (cdr binding))))

(%%test (%lookup 'a %test-env) 1)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; predicates to identify different objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; self-evaluating
(define (%self-evaluating? expr)
  (or (number? expr) (boolean? expr)))

;; special form
(define (%special? expr)
  (and (pair? expr)
       (member (car expr) 
               '(if let letrec lambda begin set! define quote))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; application and evaluation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (%apply proc largs)  
  (cond ((%primitive? proc) (%apply-internal proc largs))
        ((%closure? proc) (%apply-closure proc largs))
        (else (error "Bad ! Un-apply-able object !" proc))))

(define (%apply-internal primitive largs)   
  (apply (%primitive-function primitive) largs))

(define (%apply-closure proc largs)
  ;; apply a closure: evaluate proc body in 
  ;; extended the closure environment with
  ;; proc arguments and largs 
  (if *verbose* (printf "ApplyClosure extended env: ~a\n" (%extend-env (%closure-args proc) largs (%closure-env proc))))
  (%eval (%closure-body proc) 
         (%extend-env (%closure-args proc) largs (%closure-env proc))))
                      

(%%test (%apply-internal (%make-primitive '+ +) '(1 2 3)) 6)

(define (%eval-list l env)
  ;; list * env -> list of val
  (if (null? l)
      '()
      (cons (%eval (car l) env) (%eval-list (cdr l) env))))
          
(define (%eval expr env)
  (if *verbose* (printf "in eval ~a\n" expr) ())
  (cond ((%self-evaluating? expr) expr)                     
        ((symbol? expr) (%lookup expr env))                 
        ((%special? expr) (%eval-special expr env))
        (else 
         (%apply (%eval (car expr) env)                        
                 (%eval-list (cdr expr) env)))))

;; evaluating special forms

(define (%eval-special expr env)   
  (case (car expr)     
    ((lambda) (%eval-lambda (cdr expr) env))    
    ((if)     (%eval-if (cdr expr) env))    
    ((let)    (%eval-let (cdr expr) env))         
    ((letrec) (%eval-letrec (cdr expr) env))            
    ((set!)   (%eval-set! (cdr expr) env))        
    ((begin)  (%eval-sequence (cdr expr) env))    
    ((define) (%eval-define (cdr expr) env))      
    ((quote)  (%eval-quoted (cdr expr)))          
    (else     (error "Not yet implemented" (car expr))))) 

(define (%eval-quoted expr)
  (car expr))

(define (%eval-sequence expr env)
  ;; expr = (e1 e2 ...en)
  (letrec ((lastOfTwo (lambda (first second)
                        (%eval first env)
                        (%eval second env)))
           (loop (lambda (first rest)
                   (if (null? rest)
                       (%eval first env)
                       (loop (lastOfTwo first (car rest))
                             (cdr rest))))))
    (if (null? expr)
        '()
        (loop (car expr) (cdr expr)))))
                      
(%%test (%eval-sequence '(a b c) %test-env) 3)
(%%test (%eval-sequence '(a b) %test-env) 2)
(%%test (%eval-sequence '(a) %test-env) 1)
(%%test (%eval-sequence '((+ 2 3) (+ 3 3)) %top-level-env) 6)

(%%test (%apply-closure (%make-closure '(x) '(+ x 3) %test-env) '(100)) 103)

(define (%eval-if expr env)
  ;; evaluates the three-element list expr
  ;; expr = (e1 e2 e3)
  ;; where first element represents the conditional
  ;; second is the true case, and third is the false case
  (let ((bool (%eval (car expr) env)))
    (if bool
        (%eval (cadr expr) env)
        (%eval (caddr expr) env))))

(%%test (%eval '(if #t 3 4) %test-env) 3)
(%%test (%eval '(if #f 3 4) %test-env) 4)



(define (modify-env! id val env)
  (let ((binding (%binding id env)))
    (if (boolean? binding)
        (set-car! env (cons (%make-binding id val) (car env)))
        (set-cdr! binding val))))

(define (%eval-define expr env)
  ;; expr = (id expression)
  (modify-env! (car expr) (%eval (cadr expr) env) env)
  'undefined)

(begin 
  (%eval-define '(a 200) %test-env)
  (equal? (%lookup 'a %test-env) 200))
(begin 
  (%eval-define '(k 200) %test-env)
  (equal? (%lookup 'k %test-env) 200))

    
(define (%eval-set! expr env)
  ;; expr = (id expression)
  (let ((binding (%binding (car expr) env)))
    (if (boolean? binding)
        (error "Identifier not defined" (car expr))
        (set-cdr! binding (%eval (cadr expr) env)))))

(begin 
  (%eval-set! '(a 1999) %test-env)
  (equal? (%lookup 'a %test-env) 1999)
  (%eval-set! '(a 1) %test-env))


(define (%eval-let expr env)   
  ;; expr = (((x 3) (y 4)) x)
  (let ((lvars (map car (car expr)))          
        (lvals (map cadr (car expr)))          
        (body (cdr expr)))
    (%eval-sequence body (%extend-env lvars (%eval-list lvals env) env))))

(define (%eval-lambda expr env)
  ;; lambda in Scheme captures the environment at compile time
  ;; expr = ((x) (+ x 2))
  (if *verbose* (printf "evallambda arg: ~a env~a\n" (car expr) env) ())
  (%make-closure (car expr) (cadr expr) env))



  
(define (%extend-env-rec lids lexp env)
  ;; return a new environment in which 
  ;; lexp have been evaluated in an extended envronment in which
  ;; lids were predefined. 
  (let ((envRec (%extend-env lids lexp env)))
    (let ((newBindingTable (car envRec)))
      (for-each (lambda (binding exp)
                  (set-cdr! binding (%eval exp envRec)))
                newBindingTable lexp)
      envRec)))

(%%test (car (%extend-env-rec '(a b) '((+ 2 3) (+ 45)) %test-env)) '((a . 5) (b . 45)))

(define (%eval-letrec expr env)
  ;; expr = (((x 3) (y 4)) body)
  
  (let ((lvars (map car (car expr)))          
        (lvals (map cadr (car expr)))          
        (body (cdr expr)))
    (%eval-sequence body (%extend-env-rec lvars lvals env ))))

(%%test (%eval '(letrec ((fac 3) (yop 2))
                  (+ fac yop))
               %top-level-env) 5)

(%%test (%eval '(letrec ((fac (+ 3 4)) (yop 2))
                  (+ fac yop))
               %top-level-env) 9)

(%%test (%eval '(letrec ((fac (= 3 4)) (yop #f))
                   fac)
               %top-level-env) #f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the read-eval-loop
(define (%read)            
  (printf "? ")   
  (read)) 

(define (%print val)      
  (printf "--> ~a\n" val)
  (newline))

(define (%rep)
  ;; the read-eval-loop
  ;; enter quit to quit !sch
  
  (let ((expr (%read)))
    (if (eq? 'quit expr)
        ()
        (begin
          (%print (%eval expr %top-level-env))
          (%rep)))))

(define (%sch)
  (%initialize-top-level-env)
  (%rep))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(%eval-lambda '((x) (+ x 2)) %test-env)
(%%test (%eval '(let ((x 99) (z 44)) x) %test-env) 99)
(%%test (%eval 'z %test-env) 26)
(%%test (%eval '(begin a) %test-env) 1)
(%%test (%eval 'a %test-env) 1)
(%%test (%eval ''a %test-env) 'a)
(%eval '+ %test-env)
(%%test (%eval '(+ 2 3) %test-env) 5)
(%%test (%eval '(let ((x 2) (z 3)) (+ x z)) %test-env) 5)
(%%test (%eval '((lambda (x) (+ x x)) 5) %top-level-env) 10)
(%%test (%eval '(let ((a 1000)) (+ a 2)) %test-env) 1002)
(%eval '(let ((a 1000)) 
          (lambda (x) (+ a 2))) %top-level-env)
(%%test (%eval '(let ((a 1000)) 
          ((lambda () (+ a 22)))) %top-level-env) 1022)

(%%test (%eval '(let ((x (+ 4 5))) x) %top-level-env) 9)

(%%test (%eval '(let ((f (lambda (x) (+ x 2))))
                  (f 5)) %top-level-env) 7)

 
(%%test (%eval '(let ((a 10))
          (let ((f (lambda (x) (+ x a))))
            (let ((a 0))
              (f 5)))) %top-level-env) 15)


(%%test (%eval  '(let ((a 10))
                   (let ((f (lambda (x) (+ x a))))
                     (set! a 0)
                     (f 5))) %top-level-env) 5)

(%%test (%eval '(begin 
                  (define fac 
                    (lambda (n) 
                      (if (= 0 n) 
                          1 
                          (* n (fac (- n 1))))))
                  (fac 5))
               %top-level-env) 120)

(%%test (%eval '(let ((app (lambda (f y) (f y)))
                      (y 10))
                  (app (lambda (z) (+ z y)) 1)) 
               %top-level-env) 11)


(%%test (%eval '(let ((add (lambda (x) (lambda (y) (+ x y)))))
                  (let ((add2 (add 2)))
                    (add2 4)))
               %top-level-env) 
        6)



(%%test (%eval '(if (= 2 3) #t #f) %top-level-env) #f)

(%%test (%eval '(letrec ((fac (lambda (n) 
                                (if (= 0 n) 
                                    1 
                                    (* n (fac (- n 1)))))))
                  (fac 5))
               %top-level-env) 120)


(%%test (%eval '(letrec ((f (lambda (x) (if (= 0 x) 0 (+ 1 (g (- x 1))))))
                         (g (lambda (x) (if (= 0 x) 0 (f (- x 1))))))
                  (f 5))                               
               %top-level-env) 3)