Page Numbers: Yes X: 306 Y: 1.0" First Page: 1 Roman
Margins: Top: 1.0" Bottom: 1.3"
Heading:

des Rivìeres & SmithThe Implementation of Procedurally Reflective Languages Draft

Appendix: 3-LISP Implementation Processor Program

With very minor exceptions, this program is compatible with the dialect of 3-LISP used in the Interim 3-LISP Reference Manual.

(define 3-LISP
(lambda simple []
(&&read-normalise-print (initial-tower 2) 1 global) ))

(define &&READ-NORMALISE-PRINT
(lambda simple [state level env]
(&&normalise state (prompt&read level) env
(make-reply-continuation level env) )))

(define &&REPLY-CONTINUATION
(lambda simple [state result level env]
(block
(prompt&reply result level)
(&&read-normalise-print state level env) )))

(define &&NORMALISE
(lambda simple [state exp env cont]
(cond [(normal exp) (&&call state cont exp)]
[(atom exp) (&&call state cont (binding exp env))]
[(rail exp) (&&normalise-rail state exp env cont)]
[(pair exp) (&&reduce state (car exp)
(cdr exp) env cont )])))

(define &&REDUCE
(lambda simple [state proc args env cont]
(&&normalise state proc env
(make-proc-continuation proc args env cont) )))

(define &&PROC-CONTINUATION
(lambda simple [state proc! proc args env cont]
(if (reflective proc!)
(&&call state ↑(de-reflect proc!) args env cont)
(&&normalise state args env
(make-args-continuation proc! proc args env cont) ))))

(define &&ARGS-CONTINUATION
(lambda simple [state args! proc! proc args env cont]
(if (or (primitive proc!) (kernel-utility proc!))
(&&call state cont ↑(↑proc! . ↑args!))
(&&expand-closure state proc! args! cont) )))

(define &&EXPAND-CLOSURE
(lambda simple [state proc! args! cont]
(cond [(and (= (kernel-primary-type proc!) ’normalise)
(plausible-arguments-to-normalise args!))
(&&normalise (shift-down cont state) ; Shift down #1
↑(1st args!) ↑(2nd args!) ↑(3rd args!))]
[(and (kernel-continuation-closure proc!) ; Shift down #2
(plausible-arguments-to-a-continuation args!))
(&&call-continuation (shift-down cont state)
↑proc! ↑(1st args!))]
[$t (&&normalise state (body proc!)
(bind (pattern proc!) args! (environment proc!))
cont )])))

(define &&NORMALISE-RAIL
(lambda simple [state rail env cont]
(if (empty rail)
(&&call state cont (rcons))
(&&normalise state (1st rail) env
(make-first-continuation rail env cont) ))))

(define &&FIRST-CONTINUATION
(lambda simple [state first! rail env cont]
(&&normalise-rail state (rest rail) env
(make-rest-continuation first! rail env cont) )))

(define &&REST-CONTINUATION
(lambda simple [state rest! first! rail env cont]
(&&call state cont (prep first! rest!)) ))

(define &&LAMBDA
(lambda simple [state [kind pattern body] env cont]
(&&call state cont (ccons kind ↑env pattern body)) ))

(define &&IF
(lambda simple [state [premise c1 c2] env cont]
(&&normalise state premise env
(make-if-continuation premise c1 c2 env cont) )))

(define &&IF-CONTINUATION
(lambda simple [state premise! premise c1 c2 env cont]
(&&normalise state (ef ↑premise! c1 c2) env cont) ))

(define &&CALL
(lambda simple x
(let [[state (1st x)] [f (2nd x)] [a (rest (rest x))]]
(cond [(kernel-primary-closure ↑f)
(&&call-primary state f a)]
[(and (kernel-continuation-closure ↑f)
(= (length a) 1))
(&&call-continuation state f (1st a))]
[(or (primitive ↑f) (kernel-utility ↑f))
(&&call (shift-up state) ; Shift up for primitives
(reify-continuation state) ↑(f . a))]
[$t ; Shift up for non-primitives
(&&expand-closure (shift-up state)
↑f ↑a (reify-continuation state) )]))))

(define &&CALL-PRIMARY
(lambda simple [state f a]
(select (kernel-primary-type ↑f)
[’normalise
(&&normalise state (1st a) (2nd a) (3rd a))]
[’normalise-rail
(&&normalise-rail state (1st a) (2nd a) (3rd a))]
[’reduce
(&&reduce state (1st a) (2nd a) (3rd a) (4th a))]
[’read-normalise-print
(&&read-normalise-print state (1st a) (2nd a))]
[’if
(&&if state (1st a) (2nd a) (3rd a))]
[’lambda
(&&lambda state (1st a) (2nd a) (3rd a)) ])))

(define &&CALL-CONTINUATION
(lambda simple [state f arg]
(select (kernel-continuation-type ↑f)
[’proc (&&proc-continuation state arg
(extract ’proc f) (extract ’args f)
(extract ’env f) (extract ’cont f))]
[’args (&&args-continuation state arg
(extract ’proc! f) (extract ’proc f)
(extract ’args f) (extract ’env f)
(extract ’cont f))]
[’first (&&first-continuation state arg
(extract ’rail f) (extract ’env f)
(extract ’cont f))]
[’rest (&&rest-continuation state arg
(extract ’first! f) (extract ’rail f)
(extract ’env f) (extract ’cont f))]
[’reply (&&reply-continuation state arg
(extract ’level f) (extract ’env f))]
[’if (&&if-continuation state arg
(extract ’premise f) (extract ’c1 f)
(extract ’c2 f) (extract ’env f)
(extract ’cont f) )])))

(define MAKE-PROC-CONTINUATION
(lambda simple [proc args env cont]
↑(ccons ’simple ↑(bind ’[proc args env cont reduce]
↑[proc args env cont reduce] global)
’[proc!]
’(if (reflective proc!)
(↑(de-reflect proc!) args env cont)
(normalise args env
(lambda [args!]
(if (primitive proc!)
(cont ↑(↑proc! . ↑args!))
(normalise (body proc!)
(bind (pattern proc!) args!
(environment proc!))
cont ))))) )))

(define MAKE-ARGS-CONTINUATION
(lambda simple [proc! proc args env cont]
↑(ccons ’simple ↑(bind ’[proc! proc args env cont reduce]
↑[proc! proc args env cont reduce] global)
’[args!]
’(if (primitive proc!)
(cont ↑(↑proc! . ↑args!))
(normalise (body proc!)
(bind (pattern proc!) args!
(environment proc!))
cont )) )))

(define MAKE-FIRST-CONTINUATION
(lambda simple [rail env cont]
↑(ccons ’simple ↑(bind ’[rail env cont normalise-rail]
↑[rail env cont normalise-rail] global)
’[first!]
’(normalise-rail (rest rail) env
(lambda [rest!]
(cont (prep first! rest!)) )) )))

(define MAKE-REST-CONTINUATION
(lambda simple [first! rail env cont]
↑(ccons ’simple ↑(bind ’[first! rail env cont normalise-rail]
↑[first! rail env cont normalise-rail]
global)
’[rest!]
’(cont (prep first! rest!)) )))

(define MAKE-REPLY-CONTINUATION
(lambda simple [level env]
↑(ccons ’simple ↑(bind ’[level env read-normalise-print]
↑[level env read-normalise-print]
global)
’[result]
’(block (prompt&reply result level)
(read-normalise-print level env) ) )))

(define MAKE-IF-CONTINUATION
(lambda simple [premise c1 c2 env cont]
↑(ccons ’simple ↑(bind ’[premise c1 c2 env cont if]
↑[premise c1 c2 env cont if] global)
’[premise!]
’(normalise (ef ↑premise! c1 c2) env cont) )))

(define INITIAL-TOWER
(lambda simple [level] (scons level)) )

(define SHIFT-DOWN
(lambda simple [continuation state]
(prep continuation state) ))

(define REIFY-CONTINUATION
(lambda simple [state]
(if (= (length state) 1)
(make-reply-continuation (1st state) global)
(1st state) )))

(define SHIFT-UP
(lambda simple [state]
(if (= (length state) 1)
(scons (1+ (1st state)))
(rest state) )))

(define PLAUSIBLE-ARGUMENTS-TO-NORMALISE
(lambda simple [args!]
(and (rail args!) (= (length args!) 3)
(handle (1st args!))
(plausible-environment-designator (2nd args!))
(plausible-continuation-designator (3rd args!)) )))

(define PLAUSIBLE-ENVIRONMENT-DESIGNATOR
(lambda simple [env!]
(and (rail env!)
(or (= env! ↑global)
(empty env!)
(and (plausible-binding-designator (1st env!))
(plausible-environment-designator (rest env!)) )))))

(define PLAUSIBLE-BINDING-DESIGNATOR
(lambda simple [b!]
(and (rail b!) (= (length b!) 2)
(handle (1st b!)) (atom ↑(1st b!))
(handle (2nd b!)) )))

(define PLAUSIBLE-CONTINUATION-DESIGNATOR
(lambda simple [c!]
(and (closure c!) (not (reflective c!))
(or (atom (pattern c!))
(rail (pattern c!)) (= (length (pattern c!)) 1) ))))

(define PLAUSIBLE-ARGUMENTS-TO-A-CONTINAUTION
(lambda simple [args!]
(and (rail args!) (= (length args!) 1)
(handle (1st args!)) )))

(define EXTRACT
(lambda simple [variable function]
↑(binding variable (environment ↑function)) ))

(define KERNEL-PRIMARY-CLOSURE
(lambda simple [closure]
(not (= ’unknown (kernel-primary-type closure))) ))

(define KERNEL-PRIMARY-TYPE
(lambda simple [closure]
(identify-closure closure *kernel-primary-table*) ))

(set *KERNEL-PRIMARY-TABLE*
[[’normalise ↑normalise]
[’reduce ↑reduce]
[’normalise-rail ↑normalise-rail]
[’read-normalise-print ↑read-normalise-print]
[’lambda (de-reflect ↑lambda)]
[’if (de-reflect ↑if)] ])

(define KERNEL-CONTINUATION-CLOSURE
(lambda simple [closure]
(not (= ’unknown (kernel-continuation-type closure))) ))

(define KERNEL-CONTINUATION-TYPE
(lambda simple [closure]
(identify-closure closure *kernel-continuation-table*) ))

(set *KERNEL-CONTINUATION-TABLE*
[[’proc ↑(make-proc-continuation ’? ’? ’? ’?)]
[’args ↑(make-args-continuation ’? ’? ’? ’? ’?)]
[’first ↑(make-first-continuation ’? ’? ’?)]
[’rest ↑(make-rest-continuation ’? ’? ’? ’?)]
[’reply ↑(make-reply-continuation ’? ’?)]
[’if ↑(make-if-continuation ’? ’? ’? ’? ’?)] ])

(define KERNEL-UTILITY
(lambda simple [closure]
(member closure *kernel-utility-table*) ))

(set *KERNEL-UTILITY-TABLE*
[↑binding ↑bind ↑rebind ↑de-reflect ↑primitive ↑reflective
↑normal ↑length ↑unit ↑member ↑environment ↑double ↑1st
↑2nd ↑rest ↑vector-constructor ↑atom ↑pair ↑rail
↑handle ↑external ↑normal-rail ↑prompt&read ↑prompt&reply ])

(define IDENTIFY-CLOSURE
(lambda simple [closure table]
(cond [(empty table) ’unknown]
[(similar-closure closure (2nd (1st table)))
(1st (1st table))]
[$T (identify-closure closure (rest table))] )))

(define SIMILAR-CLOSURE
(lambda simple [closure template]
(or (= closure template)
(and (isomorphic (pattern closure) (pattern template))
(isomorphic (body closure) (body template))
(= (reflective closure) (reflective template))
(similar-environment (environment closure)
(environment template) )))))

(define SIMILAR-ENVIRONMENT
(lambda simple [environment template]
(or (= ↑environment ↑template)
(and (empty environment) (empty template))
(and (not (empty template))
(not (empty environment))
(= (1st (1st environment)) (1st (1st template)))
(or (= ’’? (2nd (1st template)))
(= (2nd (1st environment)) (2nd (1st template))))
(similar-environment (rest environment)
(rest template) )))))