; while-exp = (while condition body)
(define (while-expander while-exp)
   (define condition (cadr while-exp))
   (define body (cddr while-exp))
   (append `(do () ((not ,condition) #f)) body))

(define-syntax while while-expander)

(lazy-switch
   (delay x)
   (delay (exp 500))
   (delay (fact 40))
   (delay 100))

; exp = (switch key case1 case2 case3)
(define (switch-expander exp)
   (define key (cadr exp))
   (define case1 (caddr exp))
   (define case2 (cadddr exp))
   (define case3 (caddddr exp))
   `(lazy-switch (delay ,key)
                (delay , case1)
                (delay ,case2)
                (delay ,case3)))

(define-syntax switch switch-expander)

(define (tail stream) (force (cdr stream)))

; exp = (cons-stream head tail)
(define (cons-stream-expander exp)
   (define head (cadr exp))
   (define tail (caddr exp))
   `(cons ,head (delay ,tail)))

(define-syntax cons-stream cons-stream-expander)

(define def-name cadr)
(define def-exp caddr)

(define (expression? phrase)
   (or (literal? phrase)
       (name? phrase)
       (structure? phrase)
       (application? phrase)))

Recognizers and Selectors for Names and Literals

(define name? symbol?) ; NAME ::= SYMBOL

(define (literal? exp)
   (or (number? exp)
       (boolean? exp)
       (quoted? exp)))

(define (quoted? exp)
   (and (pair? exp) (eqv? (car exp) 'quote)))

(define rem-quote cadr)

Recognizers and Selectors for Structures and Applications

define (structure? exp)
   (and (pair? exp) (memv (car exp) structures))))

(define structures '(lambda if and or))

(define condition cadr)
(define consequent caddr)

(define (alternative if-exp)
   (if (null? (cdddr if-exp))
      #f
      (cadddr if-exp)))

(define parameters cadr)
(define body caddr)

(define operator car)
(define operands cdr)

(define application? list?) ; dangerous

Reserved Words

(define (reserved? name)
   (memv name reserved-words)))

(define reserved-words
   (append structures
          imported-names
          '(q quit quote promise define)))

; reassign return to be the current continuation:
(define (receiver cont) (set! return cont))

(define (get-phrase)
   (display alpha-prompt)
   (read))

(define alpha-prompt "Alpha> ")

(define (control-loop env)

   ; return errors here
   (call-with-current-continuation receiver)

   (let ((phrase (get-phrase)))
      (cond ((quit? phrase) 'bye)

            ((definition? phrase)
               (let ((new-env (resolve phrase env)))
                  (writeln 'done)
                  (control-loop new-env)))

            ((expression? phrase)
               (let ((val (evaluate phrase env)))
                  (writeln val))
                  control-loop env)))

          (else
            (writeln "Unrecognized phrase: " phrase)
            (control-loop env)))))

The Global Environment

(define (start-alpha)
   (writeln "Type q to quit")
   (control-loop global-env))

(define global-env
   (list
      (map cons imported-names imported-procs)))

(define imported-names
   '(+ * - / < <= > >= = not null?
      car cdr cons pair? eq? equal?))

(define imported-names
   (list + * - / < <= > >= = not null?
      car cdr cons pair? eq? equal?))

(define (install-binding symbol val env)
   (if (null? env)
       (error "empty environment" install-binding)
       (let ((frame (car env)))
         (cons (put symbol val frame) (cdr env)))))

   ; extract the optional parameter
   (define name
      (if (null? options)
         'anonymous
         (car options)))

   (cond ((literal? exp) (eval-lit exp env))
         ((name? exp) (eval-name exp env))
         ((structure? exp)
            (eval-structure exp env name))
         ((application? exp) (eval-apply exp env))
         (else (error   "unrecognized expression"
                        evaluate
                        exp))))

Evaluating Literals and Names

(define (eval-lit exp env)
   (if (quoted? exp)
      (rem-quote exp)
      exp)

(define (eval-name exp env)
   (search-env exp env))

(define (search-env symbol env)
   (if (null? env)
      (error "undefined symbol" search-env symbol)
      (let* ((frame (car env))
             (val (get symbol frame)))
         (if (eqv? val fail)
             (search-env symbol (cdr env))
             val))))

Evaluating Structures

(define (eval-structure exp env name)

   (define proc (operator exp))

   (case proc
      ((lambda) (eval-lambda exp env name))
      ((if) (eval-if exp env))
      ((and) (eval-and exp env))
      ((or) (eval-or exp env))
      (else (error   "unrecognized structure"
                     eval-structure
                     proc)))))

Short Circuit Evaluation

(define (eval-and exp env)

   (define (tail-eval result exps)
      (if (or (not result) (null? exps))
          result
          (tail-eval (evaluate (car exps) env)
                     (cdr exps))))

   (tail-eval #t (operands exp)))

(define (eval-or exp env)

   (define (tail-eval result exps)
      (if (or result (null? exps))
          result
          (tail-eval (evaluate (car exps) env)
                     (cdr exps))))

   (tail-eval #f (operands exp)))

Conditional Evaluation

(define (eval-if exp env)
   (if (evaluate (condition exp) env)
       (evaluate (consequent exp) env)
       (evaluate (alternative exp) env)))

Evaluating Lambda

(define (eval-lambda lambda-exp env name)

   ; extract components
   (define params (parameters lambda-exp))
   (define exp (body lambda-exp))

   (define (meta-proc . args)
      (define temp-frame (map cons params args))
      (define eval-env ???) ; see below
      (define temp-env (cons temp-frame eval-env))
      (evaluate exp temp-env))

   meta-proc)

Implementing the Static and Dynamic Scope Rules

(define eval-env env)

(define (meta-proc call-env . args)
      (define temp-frame (map cons params args))
      (define eval-env call-env)
      (define temp-env (cons temp-frame eval-env))
      (evaluate exp temp-env))

(define static-enabled #t)   ; #t = static scope rule
               ; #f = dynamic scope rule

(define (meta-proc call-env . args)
   (define temp-frame (map cons params args))
   (define eval-env
      (if static-enabled env call-env))
   (define temp-env (cons temp-frame eval-env))
   (evaluate exp temp-env))

The Environment Obsolescence Problem

(define (meta-proc call-env . args)
   (define temp-frame (map cons params args))
   (define eval-env
      (if static
          (install-binding name meta-proc env)
          call-env))
   (define temp-env (cons temp-frame eval-env))
   (evaluate exp temp-env))

(define (eval-lambda lambda-exp env name)

   ; extract components
   (define params (parameters lambda-exp))
   (define exp (body lambda-exp))

   (define (meta-proc call-env . args)

      (define temp-frame (map cons params args))
      (define eval-env
         (if static-enabled
             (install-binding name meta-proc env)
             call-env))
      (define temp-env (cons temp-frame eval-env))

      (evaluate exp temp-env))

   meta-proc)

Evaluating Applications

(define eager-enabled #t) ; #t = eager evaluation
                         ; #f = lazy evaluation

(define proc (evaluate (operator app) env))

(define inputs (operands app))
(define (eval-in-env e) (evaluate e env))
(define args (map eval-in-env inputs))

(define inputs (operands app))
(define (delay-in-env e) (make-promise e env))
(define args (map delay-in-env inputs))

(define (make-promise exp env)
   (list 'promise exp env))

(apply proc args)

(apply proc (cons env args))

(define (eval-apply app env)

   ; extract components
   (define proc (evaluate (operator app) env))
   (define inputs (operands app))

   ; amplifiers for map
   (define (eval-in-env e) (evaluate e env))
   (define (delay-in-env e) (make-promise e env))

(define args (if (or eager-enabled (imported? proc))
                     (map eval-in-env inputs)
                     (map delay-in-env inputs)))

   (if (imported? proc)
      (apply proc args)
      (apply proc (cons env args))))

Forcing Promises

(define (eval-name exp env)
   (define val (search-env exp env))
   (if (promise? val)
       (eval-promise val env)
       val))

(define promise-exp cadr)
(define promise-env caddr)

(define (promise? val)
   (and (pair? val) (eqv? 'promise (car val))))

(define call-by-name #t)    ; #t = call-by-name
               ; #f = call-by-text

(define (eval-promise promise env)
   (if call-by-name
      (evaluate (promise-exp promise)
                (promise-env promise))
      (evaluate (promise-exp promise) env)

   ; return errors here
   (call-with-current-continuation receiver)

   (let ((phrase (get-phrase)))
      (cond
         ((quit? phrase) 'bye)

         ((definition? phrase)
            (let* ((env1.store1
                   (resolve phrase env store))
                   (env1 (car env1.store1))
                   (store1 (cdr env1.store1)))
               (writeln 'done)
               (control-loop env1 store1)))

         ((expression? phrase)
            (let* ((val.store1
                   (evaluate phrase env store))
                   (val (car val.store1))
                   (store1 (cdr val.store1)))
               (writeln val)
               (control-loop env store1)))

         (else
            (writeln "unrecognized phrase: " phrase)
            (control-loop env store)))))

(define mem-cap 1024) ; 1 Kb memory, for now

(define (start-beta)
   (writeln "type q to quit")
   (control-loop global-env (make-store mem-cap)))

(define prompt "Beta> ")

   (define name (def-name def))
   (define exp (def-exp def))

   (if (reserved? name)
      (error "can't redefine a reserved word"
               resolve
               name)
      (let*
         ((val.store1 (evaluate exp env store name))
          (val (car val.store1))
          (store1 (cdr val.store1)))
         (if (procedure? val)
            (let
               ((new-env
                  (install-binding name val env)))
               (cons new-env store1))
            (let*
               ((ref.store2
                   (alloc-ref! store1 env val))
                (ref (car ref.store2))
                (store2 (cdr ref.store2))
                (new-store
                  (write-ref! store2 ref val))
                (new-env
                  (install-binding name ref env)))
               (cons new-env new-store))))))

   (define name
      (if (null? options) 'anonymous (car options)))

   (cond ((literal? exp) (eval-lit exp env store))
         ((name? exp) (eval-name exp env store))
         ((structure? exp)
            (eval-structure exp env store name))
         ((application? exp)
            (eval-apply exp env store))
         (else (error "unrecognized expression" evaluate exp))))

Evaluating Literals and Names

(define (eval-lit lit env store)
   (if (quoted? lit)
       (cons (rem-quote lit) store)
       (cons lit store)))

(define (eval-name name env store)
   (define val (search-env name env))
   (cond ((promise? val) (eval-promise val env store))
         ((reference? val)
            (cons (read-ref store val) store))
         (else (cons val store))))

Evaluating Structures

(define (eval-structure exp env store name)
   (let ((proc (operator exp)))
      (case proc
         ((lambda) (eval-lambda exp env store name))
         ((if) (eval-if exp env store))
         ((and) (eval-and exp env store))
         ((or) (eval-or exp env store))
         ((begin) (eval-begin exp env store))
         ((set! set-car! set-cdr!)
            (execute exp env store))
         (else (error "unrecognized structure" eval-structure proc)))))

Executing Commands

(define command-return-value #f) ; for now

(define val.store1 (evaluate exp env store))

(define ref (search-env name env))

(define (execute cmmd env store)

   (define name (cadr cmmd))
   (define exp (caddr cmmd))

   (define val.store1 (evaluate exp env store))
   (define val (car val.store1))
   (define store1 (cdr val.store1))

   (define ref (search-env name env))

   (if (reference? ref)
      (let ((ref1 (case (operator cmmd)
                     ((set-car!) (car ref))
                     ((set-cdr!) (cdr ref))
                     (else ref))) ; = set!
            (store2
               (write-ref! store1 ref1 val)))
         (cons command-return-value store2))
      (error "L-value must be a reference"
               execute
               name)))

Conditional Evaluation

(define (eval-if exp env store)

   (define val.store1
      (evaluate (condition exp) env store))
   (define val (car val.store1))
   (define store1 (cdr val.store1))

   (if val
      (evaluate (consequent exp) env store1)
      (evaluate (alternative exp) env store1)))

Short Circuit Evaluation

(define (eval-and exp env store)

   (define (tail-eval result.store exps)
      (let ((store (cdr result.store))
            (result (car result.store)))
         (if (or (not result) (null? exps))
            result.store
            (tail-eval
               (evaluate (car exps) env store)
               (cdr exps)))))

   (tail-eval (cons #t store) (operands exp)))

(define (eval-or exp env store)

   (define (tail-eval result.store exps)
      (let ((store (cdr result.store))
            (result (car result.store)))
         (if (or result (null? exps))
            result.store
            (tail-eval
               (evaluate (car exps) env store)
               (cdr exps)))))

   (tail-eval (cons #f store) (operands exp)))

Sequential Evaluation

(define (eval-begin begin-exp env store)
   (define vals.store1
      (eval-seq (cdr begin-exp) env store))
   (define vals (car vals.store1)) ; vals is a list
   (define store1 (cdr vals.store1))
   (cons (last vals) store1))

(define (eval-seq exps env store)

   (define (tail-eval vals exps store)
      (if (null? exps)
         (cons vals store)
         (let* ((val.store1
                  (evaluate (car exps) env store))
                (val (car val.store1))
                (store1 (cdr val.store1)))
            (tail-eval
               (cons-last val vals)
               (cdr exps)
               store1))))

   (tail-eval '() exps store))

Evaluating Lambda

(define (eval-lambda lambda-exp env store name)
   (define params (parameters lambda-exp))
   (define exp (body lambda-exp))
   ; for dynamic scoping also pass call-env
   (define (meta-proc call-env call-store . args)
      (define temp-frame (make-frame params args))
      (define base-env
         (if static-scope-enabled env call-env))
      (define temp-env
         (cons
          temp-frame
          (install-binding name meta-proc base-env)))
      (evaluate exp temp-env call-store))
   (cons meta-proc store))

Evaluating Applications

(define (eval-apply app env store)
   (define proc.store1
      (evaluate (operator app) env store))
   (define proc (car proc.store1))
   (define store1 (cdr proc.store1))
   (define args (operands app))
   (if (or (imported? proc) eager-enabled)
      (let*
         ((inputs.store2 (eval-seq args env store1))
          (inputs (car inputs.store2))
          (store2 (cdr inputs.store2)))
       (if (imported? proc)
            (cons (apply proc inputs) store2)
            (apply proc
                   (cons env (cons store2 inputs)))))
      (let* ((inputs (delay-seq args env store1)))
         (apply proc
                (cons env (cons store1 inputs))))))

Delay Sequence

(define (delay-seq exps env store)
   (define (tail-delay promises exps store) ...)
   (tail-delay '() exps store))

(define (tail-delay promises exps store)
   (if (null? exps)
      promises
      (let*
         ((promise (make-promise (car exps) env)))
       (tail-delay
         (cons-last promise promises)
         (cdr exps)
         store))))

(define (cons-last val vals) (append vals (list val))

Forcing Promises

(define (eval-promise promise env store)
   (if call-by-text
      (evaluate (promise-exp promise) env store)
      (evaluate (promise-exp promise)
                (promise-env promise)
                store)))

(define (start-lambda)
   (writeln "Type q to quit")
   (control-loop '())) ; empty environment!

(define prompt "Lambda> ")

(define structures '(lambda))

(define eager-enabled #f)

(define (literal? exp) #f)

(define (val->name val env)
   (if (null? env)
      val ; give up and return the original value
      (let* ((frame (car env))
             (iframe (invert frame))
             (name (get val iframe)))
         (if (eqv? name undefined-symbol)
             (val->name val (cdr env))
             name))))

Lambda Calculus Definitions

Booleans

(define true (lambda (x y) x))
(define false (lambda (x y) y))

(define if
   (lambda (x y z) (x y z)))

(define and
   (lambda (x y)
      (if x y false)))

(define or
   (lambda (x y)
      (if x true y)))

(define not
   (lambda (x)
      (if x false true)))

Pairs

(lambda (z) (z x y)) ; = (x . y)

(define cons
   (lambda (x y)
      (lambda (z) (z x y))))

(define car
   (lambda (pair) (pair true)))

(define cdr
   (lambda (pair) (pair false)))

Natural Numbers

(define n0 (cons true true))

(define zero?
   (lambda (z) (car z)))

(define add1
   (lambda (num)
      (cons false num)))

(define n1 (add1 n0))
(define n2 (add1 n1))
(define n3 (add1 n2))
(define n4 (add1 n3))
(define n5 (add1 n4))
(define n6 (add1 n5))
(define n7 (add1 n6))
(define n8 (add1 n7))
(define n9 (add1 n8))
(define n10 (add1 n9))

(define sub1
   (lambda (num)
      (if (zero? num) num (cdr num))))

(define +
   (lambda (x y)
      (if (zero? x) y (+ (sub1 x) (add1 y)))))

(define =
   (lambda (x y)
      (if (and (zero? x) (zero? y))
         true
         (if (or (zero? x) (zero? y))
            false
            (= (sub1 x) (sub1 y))))))