;;; June 6, 1984
;;; This implementation of 3-lisp in 3-lisp is the one
;;; presented in the implementation paper [des Rivieres & Smith 84]
;;; This program does work, albeit slowly. The examples which it
;;; handled successfully were:
;;;
;;; 100
;;; (+ 2 2)
;;; (lambda simple [x] x)
;;; ((lambda simple [x] x) 10)
;;; (cond [$f 1] [(= 2 2) 4])
;;; ((lambda reflect [a e c] (c '3)))
;;; (set z 99)
;;; and (block 1 2)
;;;
;;; (and boy, was it slow!)
(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]
(block (print exp primary-stream) (newline primary-stream)
(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)
\(1st args!) \(2nd args!) \(3rd args!))]
[(and (kernel-continuation-closure proc!)
(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)
(reify-continuation state) ↑(f . a))]
[$t
(&&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 level result)
(: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]
(block (print '<shifting-down> primary-stream) (newline primary-stream)
(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]
(block (print '<shifting-up> primary-stream) (newline primary-stream)
(if (= (length state) 1)
(scons (1+ (1st state)))
(define PLAUSIBLE-ARGUMENTS-TO-A-CONTINUATION
(lambda simple [args!]
(and (rail args!) (= (length args!) 1)
(handle (1st args!)) )))
(define PLAUSIBLE-ARGUMENTS-TO-NORMALISE
(lambda simple [args!]
(block (print '<plausible> ps) (newline ps)
(print args! ps) (newline ps)
(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 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
↑append ↑append*
↑1st ↑2nd ↑3rd ↑4th ↑5th ↑6th ↑unit ↑double ↑member
↑:prompt&read ↑:prompt&reply ↑environment] )
(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) )))))
(define :read-normalise-print
(lambda simple [level env]
(normalise (:prompt&read level) env
(lambda simple [result]
(block (:prompt&reply result level)
(:read-normalise-print level env) )))))
(define :prompt&read
(lambda simple [level]
(prompt&read level primary-stream) ))
(define :prompt&reply
(lambda simple [result level]
(prompt&reply result level primary-stream) ))