;;;; Brown interpreter from Friedman & Wand (1984)

;;; From the Appendix:

;; tagging functions and aliases

(define tacit cons)
(define tag car) 

(define body cdr)
(define value-of car)
(define first car)
(define second cadr)
(define rest cdr)
(define wrap/quote (lambda (v) (list 'quote v)))
(define I (lambda (x) x)) 

;; syntactic auxiliaries

(define abs?
(lambda (f) (eq? (tag f) 'abs)))

(define reifier?
(lambda (f) (eq? (tag f) 'reify)))

(define simple?
(lambda (f) (eq? (tag f) 'simple)))

(define syntactic-type
(lambda (e)
(cond
((atom? e) 'identifier)
((abs? e) 'abstraction)
(t 'application)))) 

;;; Section 2: The Interpreter

(define denotation
(lambda (e)
(case (syntactic-type e)
[identifier (<identifier> e)]
[abstraction
(let ([b (body e)])
(<abs>
(if (reifier? b)
<reify>
<simple>)
(body b)))]
[appllcatlon (<app> e)]))) 

(define <identifier>
(lambda (e)
(lambda (r k)
(r •
(lambda (cell)
(k (value-of cell))))))) 

(define <app>
(lambda (e)
(lambda (r k)
((denotation (first e))
r
(lambda (f)
(f (rest e) r k)))))) 

(define <abs>
(lambda (abs-builder e)
(lambda (r k)
(k (abs-builder
(lambda (v* c)
((denotation (second e))
(extr (first e) v*)
c))))))) 

(define <reify>
(lambda (fun)
(lambda (e r k)
(fun
(list
e
(schemeU-to-brown r)
(schemeK-to-brown k))
wrong))))

(define <simple>
(lambda (fun)
(lambda (e r k)
((ree loop
(lambda (e k)
(if (null? e) (k nil)
((denotation (first e))
r
(lambda (v)
(loop
(rest e)
(lambda (w)
(k (cons v w)))))))))
(lambda (v*) (fun v* k)))))) 

(define meaning
nment to
(<simple>
(lambda (v* c)
(c ((denotation (car v*))
(brown-to-echemeU (cadr v*))
(brown-to-schemeK (caddr v*)))))) 

(define ef (lanbda (b
x y) (if b x y))).

;;; Section 3: Reification and Reflection	

(define schemeF-to-brown <simple>)

(define brown-to-schezeF
(lanbda (bf)
(lambda (v* c)
(bf (mapcar wrap/quote v*) Inltenv c)))) 

(define schemeK-to-brown
(lambda (k)
(lanbda (e r kl)
(if (= (length e) 1)
((denotation (first e)) r k)
(wrong
(llst
"schemeK-to-brown: "
"wrong number of args "
e)))))) 

(define brown-to-schemeK
(lmbda (bf)
(lambda (v)
(bf (list (wrap/quote v)) initenv I)))) 

(define schemeU-to-brown
(lambda (r)
(lambda (e rl kl)
(if (= (length e) I)
((denotation (first e))
rl
(lambda (v) (r v kl)))
(wrong
(list
"schemeU-to-brown: "
*'wrong no of args"
e))))))

(define brown-to-schemeU
(lambda (bf)
(laabda (v c)
(bf (wrap/quote v) initenv c)))) 

(define nullenv
(lambda (v c)
(wrong (list "brown: unbound id " v)))) 

(define err
(lambda (r vats vale)
(if (= (length wars) (length vale))
(lambda (v c)
((rec lookup
(lambda (wars vale)
(cond [(null? wars) (r v c)]
[(eq? (first wars) v)
(( vals)]
It (lookup
(rest wars)
(rest vale))])))
wars vale))
(begin
(writeln
"Brown: wrong number of actuals")
(wrlteln "Formals: " wars)
(writeln "Actuals: " vale)
(wrong **ext failed'*)))))

;;; From the Appendix:

;; auxiliaries for setting up initenv

;; convert direct scheme fcns to SchemeF

(define scheme-to-schemeF
(lambda (f)
(Z~abda (v* c)(c (apply f v*)))))

(define define-brownl
(lambda (name exp)
(call/cc
(lambda (caller)
((denotation exp)
initenv
(lambda (v)
(set! initenv
(ext initenv
(list name)
(lint v)))
(caller name)))))))

;; define-brown macro changed to syntax-rules

(define-syntax define-brown
  (syntax-rules ()
    ((define-brown id val) (define-brown1 'id 'val))))

;;; From the Appendix:

(define boot-tnttenv
(lambda 0
(let
((scheme-fn-table
(list
(cone 'car car)
(cons 'cdr cdr)
(cone 'cone cons)
(cone 'eq? eq?)
(cons 'atomy atomY)
(cons 'null? null?)
(cons 'addl addl)
(cone 'eubl eubl)
(cone '=0 =0)
(cons '+ +)
(cons '- -)
(cons '* *)
(cons 'print print)
(cons 'length length)
(cone 'reed read)
(cone 'ezt
(lambda (br p* v*)
(schemeU-to-brown
(ext
(brown-to-schemeU br)
p*
v*))))
(cons 'nullenv nullenv)
(cons 'update-store
(laabda (x y)
(value-of (set-car! x y))))
(cons 'reifier? reifier?)
(cons 'simple? staple?)
(cone 'abs? abs?)
(cons 'wrong wrong)
(cone 'el
(lambda (bool x y) (if bool x y)))
(cons "newline newline)
(cone 'aeaning
(lmbda (e r k)
((denotation e)
(brown-to-scheaeU r)
(brown-to-echemeK k)))))))
(let ((inltvare (mapcar car echeme-fn-table))
(initvale
(mapcar
(laabda (x)
(schemeF-to-bron
(scheme-to-schemeF (cdr x))))
scheme-fn-table)))
(define initenv
(e~ (ext nullenv '(nil t) '(nil t))
initvare
initvals))
(define-brown quote
(abs reify (e r k) (k (car e))))))))

(boot-lnttenv) 

;;; Section 4: The Initial Environment

(define run
(lambda (e)
(call/co
(lambda (caller)
((denotation e) initenv caller))))) 

(define wrong
(lambda (v)"
(writeln "wrong: " v) (reset))) 

;;; Section 5: Defining Special Forms

(define-brown call/cc
(abs simple (f)
((abs reify (e r k) (k (f k)))))) 
(define-brown macro
(abs simple (bf)
(abs retry (e r k)
(meaning (bf e) r k)))) 

(define-brown lambda
(macro
(abs simple (e)
(cons 'abs (cons 'simple e))))) 

(deflne-brown set!
(abs reify (e r k)
(meaning (car (cdr e)) r
(abs simple (v)
(k (update-store
(r (car e))
v)))))) 

(define-brown begin
(abs retry (e r k)
((abs simple (dumy)
(meaning (car (cdr e)) r k))
(meaning (car e) r (abs simple (x) x))))) 

(define-brown begin-1
(abs retry (e r k)
((abs simple (dumy)
(meaning (car (cdr e)) r k))
(meaning (car e) r (abs simple (x) x))))) 

(define-brown begin-2
(abs reify (e r k)
(meaning (car e) r
(abs simple (v)
(meaning (car (cdr e)) r k))))) 

(define-brown fixi
(abs simple (f)
((abs simple (d) (d d))
(abs simple (g)
(abs simple (x) ((f (g g)) x))))))

(define-brown begin
(abs reify (e r k)
((fixi
(abs simple (loop)
(abs simple (e)
(if (null? (cdr e))
(meaning (car e) r k)
(meaning (car e) r
(abs simple (v)
(loop (cdr e)))))))) 

(define-brown lexpr
(abs reify (e r k)
(k (abs reify (el rl kl)
(meaning* el rl
(abs simple (v*)
(meaning
(car (cdr e))
(ext r (car e) (cons v* nil))
kl))))))) 

(define-brown attach
(abs rsify (e r k)
(meaning
(car (cdr s))
(abs simple (v)
(begin
(if (eq? v (car e))
(print "Probed !")
nil)
(r v)))
k)))