[phylum]<3-LISP>documentation>3-deus.bravo!7

(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 :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]
(cond [(primitive proc!) (call cont ↑(↑proc! . ↑args!))]
[(processor-procedure proc!)
(block (shift-down cont)
(register ↑proc! ↑args!)
((implementation-of proc!) . ↑args!))]
[$T (expand-closure proc! args! 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 EXPAND-CLOSURE
(lambda simple [proc! args! cont]
(call normalise (body proc!)
(bind (pattern proc!) args! (environment proc!))
cont)))

(define CALL
(lambda macro exp
̀ (let [[fun ,(1st exp)]]
(if (or (reflective ↑fun) (primitive ↑fun))
(expand-closure @last-processor-procedure @last-processor-args (shift-up))
(call-simple fun ,(rest exp))))))

(define CALL-SIMPLE
(lambda simple [fun args]
(if (processor-procedure ↑fun)
(block (register fun args)
((implementation-of ↑fun) . args))
(expand-closure ↑fun ↑args (shift-up)))))

(define IMPORT
(lambda macro [vars body]
̀ (let ,(map (lambda simple [var]
̀ [,var ↑(binding ,↑var (environment @last-processor-procedure))])
vars)
,body)))

(define MAKE-CONTINUATION
(lambda simple [template]
(simple ↑(bind (pattern @last-processor-procedure)
@last-processor-args
(environment @last-processor-procedure))
(pattern template)
(body template))))

(define GENESIS
(lambda simple []
(block (set @level-stack (scons))
(set @current-level 1)
(call read-normalise-print 1 global primary-stream))))

(define SHIFT-UP
(lambda simple []
(block (set @current-level (1+ @current-level))
(if (empty @level-stack)
(new-top-level-continuation @current-level)
(pop @level-stack)))))

(define NEW-TOP-LEVEL-CONTINUATION
(letseq [[rnp-environment (environment ↑read-normalise-print)]
[rnp-pattern (pattern ↑read-normalise-print)]
[rnp-body (body ↑read-normalise-print)]
[c-reply-pattern (2nd (cdr (3rd (cdr rnp-body))))]
[c-reply-body (3rd (cdr (3rd (cdr rnp-body))))]]
(lambda simple [level]
(simple ↑(bind rnp-pattern
↑[level global primary-stream]
rnp-environment)
c-reply-pattern
c-reply-body))))

(set @SAMPLE-C-PROC! ↑(catch ((throw-cont))))
(set @SAMPLE-C-ARGS! ↑(catch (id* . (throw-cont))))
(set @SAMPLE-C-FIRST! ↑(catch [’? (throw-cont)]))
(set @SAMPLE-C-REST! (binding ’cont (environment @sample-c-first)))

(set TABLE-OF-EQUIVALENTS [[↑normalise :normalise]
[↑normalise-rail :normalise-rail]
[↑reduce :reduce]
[@sample-c-proc! :c-proc!]
[@sample-c-args! :c-args!]
[@sample-c-first! :c-first!]
[@sample-c-rest! :c-rest!]])

(define PROCESSOR-PROCEDURE
(lambda simple [proc]
(do [[table table-of-equivalents (rest table)]]
[[(empty table) $F]
[(match-closure proc (1st (1st table))) $T]])))

(define IMPLEMENTATION-OF
(lambda simple [proc]
(do [[table table-of-equivalents (rest table)]]
[[(match-closure proc (1st (1st table))) (2nd (1st table))]])))

(define MATCH-CLOSURE
(lambda simple [candidate master]
(and (= (body candidate) (body master))
(= (pattern candidate) (pattern master))
(= (procedure-type candidate) (procedure-type master))
(match-env (environment-designator candidate)
(environment-designator master)))))

(define MATCH-ENV
(lambda simple [candidate master]
(cond [(= master ↑global) $F]
[(= candidate master) $T]
[$T (and (not (empty candidate))
(rail (1st candidate))
(double (1st candidate))
(= (1st (1st candidate)) (1st (1st master)))
(match-env (rest candidate) (rest master)))])))

The foregoing is inefficient in various places: CALL is sometimes called with one of the three named processor procedures (NORMALISE, REDUCE, or NORMALISE-RAIL), but goes through a bunch of unncessary checks to make sure that it isn’t primitive or reflective, and then looks up the implementation version. However the calling code knows perfectly well what that implementation procedure will be (specifically, :NORMALISE, :REDUCE, or :NORMALISE-RAIL). In the following, therefore, we change things slightly so as to take advantage of this optimisation.

(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 :C-PROC!
(lambda simple [proc!]
(import [args env cont]
(if (reflective proc!)
(call-simple ↑(de-reflect proc!) [args env cont])
(call-normalise args env
(make-continuation @sample-c-args!))))))

(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 EXPAND-CLOSURE
(lambda simple [proc! args! cont]
(call-normalise (body proc!)
(bind (pattern proc!) args! (environment proc!))
cont)))

(define CALL-SIMPLE
(lambda simple [fun args]
(if (processor-procedure ↑fun)
(block (register fun args)
((implementation-of ↑fun) . args))
(expand-closure ↑fun ↑args (shift-up)))))

(define IMPORT
(lambda macro [vars body]
̀ (let ,(map (lambda simple [var]
̀ [,var ↑(binding ,↑var (environment @last-processor-procedure))])
vars)
,body)))

(define GENESIS
(lambda simple []
(block (set @level-stack (scons))
(set @current-level 1)
(expand-closure ↑read-normalise-print
↑[1 global primary-stream]
(shift-up)))))

(define SHIFT-UP
(lambda simple []
(block (set @current-level (1+ @current-level))
(if (empty @level-stack)
(new-top-level-continuation @current-level)
(pop @level-stack)))))

(define PROCESSOR-PROCEDURE
(lambda simple [proc]
(do [[table table-of-equivalents (rest table)]]
[[(empty table) $F]
[(match-closure proc (1st (1st table))) $T]])))

(define IMPLEMENTATION-OF
(lambda simple [proc]
(do [[table table-of-equivalents (rest table)]]
[[(match-closure proc (1st (1st table))) (2nd (1st table))]])))

(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 EXPAND-CLOSURE
(lambda simple [proc! args! cont]
(call-normalise (body proc!)
(bind (pattern proc!) args! (environment proc!))
cont)))

(define GENESIS
(lambda simple []
(block (set @level-stack (scons))
(set @current-level 1)
(expand-closure ↑read-normalise-print
↑[1 global primary-stream]
(shift-up)))))

In addition, the processor can be extended so as to handle compiled versions of kernel (or indeed any non-continuation-passing) procedures as follows:

(define :C-ARGS!
(lambda simple [args!]
(import [proc! cont]
(cond [(or (primitive proc!)
(and (compiled proc!)
(not (reflective ↑cont))
(not (primitive ↑cont))))
(call cont ↑(↑proc! . ↑args!))]
[(processor-procedure proc!)
(block (shift-down cont)
(register ↑proc! ↑args!)
((implementation-of proc!) . ↑args!))]
[$T (expand-closure proc! args! cont)]))))

(set COMPILED-PROCEDURES
(map up
[** 1+ 1- 1st 2nd 3rd 4th 5th 6th abs append append* atom bind binding
boolean character character-string charat closure concatenate copy-vector
de-reflect double environment even external foot function handle id id*
index internal isomorphic macro macro-expander map max member min negative
newline non-negative normal normal-rail not number numeral odd pair pop
positive primitive print prompt&read prompt&reply push rail read rebind
reflect reflect! reflectify reflective remainder rest reverse rplaca
rplacd rplacn rplact sequence simple stream streamer truth-value unit
vector vector-constructor xcons y-operator zero]))

Finally, to handle kernel reflectives (such as IF) one needs in general to a) define implementation procedures for the main body of the reflective procedure and for each of the continuations it constructs (of which IF has one), b) construct a sample closure for those continuations and for the de-reflected version of the main procedure, and c) add an appropriate entry to the TABLE-OF-EQUIVALENTS. For example, to deal with the standard rather complex IF that allows rail and non-rail args, we would add (note that :IF implements ↑(de-reflect ↑if), and is therefore simple and in continuation-passing style):

(define :IF
(lambda simple [args env cont]
(if (rail args)
(call-normalise (1st args) env
(make-continuation @sample-c-if))
(call-reduce ↑ef args env cont))))

(define :C-IF
(lambda simple [premise!]
(import [args env cont]
(call-normalise (if ↑premise! (2nd args) (3rd args)) env cont))))

(define :READ-NORMALISE-PRINT
(lambda simple [level env stream]
(call-normalise (prompt&read level stream) env
(make-continuation @sample-c-reply))))

(define :C-REPLY
(lambda simple [result]
(import [level env stream]
(block (prompt&reply result level stream)
(call-read-normalise-print level env stream)))))

(define CALL-READ-NORMALISE-PRINT
(lambda simple args
(block (register read-normalise-print args) (:read-normalise-print . args))))

(define GENESIS
(lambda simple []
(block (set @level-stack (scons))
(set @current-level 1)
(call-read-normalise-print 1 global primary-stream))))

;;; (define DEFINE
;;; (lambda macro [label body]
;;; ̀ (block (set ,label (y-operator (lambda simple [,label] ,body)))
;;; ,↑label)))

Note that this definition does not make accessible to any instance of it a rail that is shared by all definitions (i.e. it sets up no own variables). If it did, we would have to extract a handle to that very rail; as it is, we can construct a fresh version:

(define :DEFINE
(lambda simple [[label body] env cont]
(call-normalise ̀ (block (set ,label (y-operator (lambda simple [,label] ,body)))
,↑label)
env
cont)))