Page Numbers: Yes X: 306 Y: 1.0" First Page: 30
Margins: Top: 1.0" Bottom: 1.3"
Heading:
CS-370 (FALL 1982)3-LISP REFERENCE MANUALNovember 10, 1982
—————————————————————
10. A Direct Embedding of 3-LISP in 3-LISP
—————————————————————
Since the 3-LISP reflective tower is infinite, the reflective processor doesn’t reveal how 3-LISP is finite. This section presents a 3-LISP program that implements, within 3-LISP, a full virtual tower, with structural field, global environment, etc., isomorphically embedded (i.e. a rail is implemented directly as a rail, etc.). This processor bears the same relationship to 3-LISP as standard meta-circular processors bear to standard LISPs.
This version is presented using DEFINEs, but in fact if you were to run this you would have to establish all of these procedures definitions in a giant LABELS, since otherwise these definitions will be visible in the global environment, which would be incorrect. It is crucial, however, that the environment we hand out (through READ-NORMALISE-PRINT) be the real global environment, so that when user code reflects it gets access to the genuine article.
[NB: This code still needs to be thoroughly commented and tested ... ]
————————————————————————————————————————————
*NORMALISE, *REDUCE, and *NORMALISE-RAIL
(define *NORMALISE
(lambda simple [exp env cont]
(cond [(normal exp) (call cont exp)]
[(atom exp) (call cont (binding exp env))]
[(rail exp) (call normalise-rail exp env cont)]
[(pair exp) (call reduce (car exp) (cdr exp) env cont)])))
(define *REDUCE
(lambda simple [proc args env cont]
(call normalise proc env
(make-continuation @sample-C-proc!))))
(define *C-PROC!
(lambda simple [proc!]
(import [args env cont]
(if (reflective proc!)
(call ↑(de-reflect proc!) args env cont)
(call normalise args env
(make-continuation @sample-C-args!))))))
(define *C-ARGS!
(lambda simple [args!]
(import [proc! cont]
(if (primitive proc!)
(call cont ↑(↑proc! . ↑args!))
(block (shift-down cont)
(call ↑proc! ↑args!))))))
(define EXPAND-CLOSURE
(lambda simple [proc! args! cont]
(call normalise (body proc!)
(bind (pattern proc!) args! ↑(environment proc!))
cont)))
(define *NORMALISE-RAIL
(lambda simple [rail env cont]
(if (empty rail)
(call cont (rcons))
(call normalise (1st rail) env
(make-continuation @sample-C-first!)))))
(define *C-FIRST!
(lambda simple [first!]
(import [rail env]
(call normalise-rail (rest rail) env
(make-continuation @sample-C-rest!)))))
(define *C-REST!
(lambda simple [rest!]
(import [first! cont]
(call cont (prep first! rest!)))))
————————————————————————————————————————————
CALL
We can’t call object-level continuations with (cont ...), since if they were reflective, that would cause us to reflect, rather than enabling us to reflect the tower we are running. Similarly we can’t call any of the seven PPPs (primary processor procedures) directly, like NORMALISE and C-PROC!, since we need to use our own private versions of them (*NORMALISE, *C-PROC!, etc.). Also, we can’t call simple user procedures directly if they are not PPPs, since we won’t have compiled code for them; they require that we shift up and expand their bodies explicitly. Finally, we can’t call primitives directly, since they return, which would be fatal: we are not supposed to return; if the user code returns we need to send the result to the continuation stacked overhead. For all these reasons we use CALL as a linkage protocol between every PPP call, to sort things out.
(define CALL (lambda macro args ̀ (*call ,(1st args) (delay ,(rest args)))))
(define *CALL
(lambda simple [fun delayed-args]
(cond [(primitive ↑fun) (chicken-out-for-primitive)]
[(reflective ↑fun) (chicken-out-for-reflective)]
[$T (block (set @last-fun fun)
(set @last-args (force delayed-args))
(cond [(= ↑fun ↑normalise) (*normalise . @last-args)]
[(= ↑fun ↑normalise-rail) (*normalise-rail . @last-args)]
[(= ↑fun ↑reduce) (*reduce . @last-args)]
[(C-match ↑fun @sample-c-proc!) (*C-proc! . @last-args)]
[(C-match ↑fun @sample-c-args!) (*C-args! . @last-args)]
[(C-match ↑fun @sample-c-first!) (*C-first! . @last-args)]
[(C-match ↑fun @sample-c-rest!) (*C-rest! . @last-args)]
[$T (expand-closure ↑fun ↑@last-args (shift-up))]))])))
————————————————————————————————————————————
CHICKENING-OUT
Each of these two version of CHICKEN-OUT backs up. CHICKEN-OUT-FOR-PRIMITIVE has to build a C-ARGS! continuation that would have existed one level up, had we been running this up one level. To do this, it must also assemble the C-PROC! continuation that the C-ARGS! continuation would have CONT bound to within it. It is setting up conditions to look as it it had entered REDUCE with some PROC, ARGS, and ENV, and had normalised PROC and ARGS to get PROC! and ARGS!, and is now ready to call the C-ARGS!continuation. It will now definitely expand the PROC! closure (crucially, PROC! is not bound to a primitive). Therefore, the first three elements of the sequence that @LAST-ARGS is bound to are irrelevant, because we outselves will only need PROC!, ARGS!, and CONT (i.e., we don’t need PROC, ARGS, and ENV), and (ready?) there is no possibility that we will have to reflect in the next step, after which these bindings will be thrown away. I.e., because we will take the EXPAND-CLOSURE route, there is no possibility we will be forced to shift-up (as there would have been if PROC! had been bound to a primitive and CONT had been reflective) while within the lexical contour of the call to REDUCE.
(define CHICKEN-OUT-FOR-PRIMITIVE
(lambda simple []
(let [[proc! ↑@last-fun]
[args! ↑@last-args]]
(block (set @last-fun reduce)
(set @last-args [’? ’? ’? (shift-up)]); Ignore PROC, ARGS, and ENV
(set @last-fun (make-continuation @sample-C-proc!))
(set @last-args proc!)
(*call (make-continuation @sample-C-args!) (delay args!))))); Try again
(define CHICKEN-OUT-FOR-REFLECTIVE
(lambda simple [] (expand-closure ↑@last-fun ↑@last-args (shift-up))))
————————————————————————————————————————————
(define C-MATCH
(lambda simple [closure template]
(and (= (body closure) (body template))
(= (pattern closure) (pattern template))
(= (procedure-type closure) ’simple)
(match-env (environment closure) (environment template)))))
(define MATCH-ENV
(lambda simple [candidate master]
(cond [(= candidate master) $T]
[(= master ↑global) $F]
[(empty candidate) $F]
[(= (1st (1st candidate)) (1st (1st master)))
(match-env (rest candidate) (rest master))]
[$T $F])))
————————————————————————————————————————————
CONTINUATION UTILITIES
(define MAKE-CONTINUATION
(lambda simple [template]
(simple ↑(bind (pattern ↑@last-fun) ↑@last-args ↑(environment ↑@last-fun))
(pattern template))
(body template))))
(define IMPORT
(lambda macro [vars body]
(if (empty vars)
body
̀ (let ,(map (lambda simple [var]
̀ [,var ↑(binding ,↑var ↑(environment ↑@last-fun))])
vars)
,body))))
————————————————————————————————————————————
SHIFT-UP and SHIFT-DOWN
SHIFT-UPpretends that we are now playing reflective processor at one level higher that we were just a moment ago, and adjusts the continuation stack so that it accurately reflects our new stance. Similarly, SHIFT-DOWN pretends that we are going to play reflective processor at one level lower than we were a moment ago, and saves the continuation for our former level on the continuation stack.
(define SHIFT-UP
(lambda simple []
(block (set @current-level (1+ @current-level))
(if (empty @continuation-stack)
(new-top-level-continuation @current-level)
(pop @continuation-stack)))))
(define SHIFT-DOWN
(lambda simple [cont]
(block (set @current-level (1- @current-level))
(push cont @continuation-stack))))
————————————————————————————————————————————
GENESIS
GENESIS starts things off at level 1 with an empty continuation stack. Note that the call to READ-NORMALISE-PRINT will cause a shift up, although the embedded call to NORMALISE within it will subsequently drop back down again.
(define GENESIS
(lambda simple []
(let [[throw-out-cont (lambda reflect [[] e c] ↑↑c)]]
(block (set @continuation-stack (scons))
(set @current-level 1)
(set @sample-c-first! (catch [(throw-out-cont)]))
(set @sample-c-proc! (catch ((throw-out-cont))))
(set @sample-c-args! (catch (id* . (throw-out-cont))))
(set @sample-c-rest!
(catch [’? ((lambda reflect [[] e c] ↑(binding ’cont ↑(environment ↑c))))]))
(set @sample-c-block (catch (block (throw-out-cont) ’?)))
(call read-normalise-print 1 global))))
————————————————————————————————————————————
NEW-TOP-LEVEL-CONTINUATION
The tower (hanging garden) we implement is allegedly initialised with incantantions of the following form:
#> (read-normalise-print # global)
...
3> (read-normalise-print 2 global)
2> (read-normalise-print 1 global)
This means that the great flurry of activity at level 1 is supposedly driven by the call to NORMALISE inside READ-NORMALISE-PRINT, whose definition is:
(define READ-NORMALISE-PRINT
(lambda simple [level env]
(block (prompt level)
(normalise (read stream) env print)
(read-normalise-print level env))))
(define NEW-TOP-LEVEL-CONTINUATION
(let [[rnp-code-fragment (rest (cdr (body ↑read-normalise-print)))]
[rnp-environment ↑(environment ↑read-normalise-print)]
[rnp-pattern (pattern ↑read-normalise-print)]]
(lambda simple [level]
(block (set @last-fun block-helper)
(set @last-args [rnp-code-fragment
(bind rnp-pattern ↑[level global] rnp-environment)
print])
(make-continuation @sample-c-block)))))
————————————————————————————————————————————