[phylum]<3-LISP>documentation>2-lisp>2-processor.bravo!6

————————————————————————————————————————————

(define READ-NORMALISE-PRINT
(lambda expr [env stream]
(block (prompt stream)
(normalise (read stream) env
(lambda expr [exp!] (reply exp! stream)))
(read-normalise-print env stream))))

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

(define REDUCE
(lambda expr [proc args env cont]
(normalise proc env
(lambda expr [proc!]
(selectq (procedure-type proc!)
[expr (normalise args env
(lambda expr [args!]
(if (primitive proc!)
(reduce-primitive-expr proc! args! env cont)
(expand-closure proc! args! cont))))]
[impr (if (primitive proc!)
(reduce-primitive-impr proc! args env cont)
(expand-closure proc! ↑args cont))]
[macro (expand-closure proc! ↑args
(lambda expr [result]
(normalise result env cont)))])))))

(define NORMALISE-RAIL
(lambda expr [rail env cont]
(if (empty rail)
(cont (rcons))
(normalise (1st rail) env
(lambda expr [element!]
(normalise-rail (rest rail) env
(lambda expr [rest!]
(cont (prep element! rest!)))))))))

;;; EXPAND-CLOSURE
;;; REDUCE-PRIMITIVE-EXPR
;;; REDUCE-PRIMITIVE-IMPR
;;; ---------------------

(define EXPAND-CLOSURE
(lambda expr [closure! args! cont]
(normalise (body closure!)
(bind (pattern closure!) args! ↑(cenv closure!))
cont)))

(define REDUCE-PRIMITIVE-EXPR
(lambda expr [proc! args! env cont]
(select proc!
[↑normalise (normalise ↑(1st args!) env
(lambda expr [result] (cont ↑result)))]
[↑reduce (reduce ↑(1st args!) ↑(2nd args!) env
(lambda expr [result] (cont ↑result)))]
[$T (cont ↑(↑proc! . ↑args!))])))

(define REDUCE-PRIMITIVE-IMPR
(lambda expr [proc! args env cont]
(select proc!
[↑set (normalise (2nd args) env
(lambda expr [binding!]
(rebind (1st args) binding! env)
(cont binding!)))]
[↑lambda (reduce (1st args)
↑[↑env (2nd args) (3rd args)])
env
cont)]
[↑if (normalise (1st args) env
(lambda expr [prem!]
(normalise (if ↑prem! (2nd args) (3rd args))
env
cont)))])))

(define NORMAL
(lambda expr [x]
(selectq (type x)
[[atom pair] $F]
[[numeral charat boolean handle closure] $T]
[rail (normal-rail x)])))

(define NORMAL-RAIL
(lambda expr [rail]
(cond [(empty rail) $T]
[(normal (1st rail)) (normal-rail (rest rail))]
[$T $F])))

(define PRIMITIVE
(lambda expr [proc]
(member proc
[↑type ↑= ↑pcons ↑rcons ↑scons ↑ccons ↑acons ↑car ↑cdr ↑prep
↑length ↑nth ↑tail ↑replace ↑if ↑up ↑down ↑+ ↑* ↑- ↑/ ↑lambda
↑set ↑input ↑output ↑procedure-type ↑cenv ↑body ↑pattern
↑normalise ↑reduce])))

(define BINDING
(lambda expr [var env]
(if (= var (1st (1st env)))
(2nd (1st env))
(binding var (rest env)))))

(define BIND
(lambda expr [pattern args bindings]
(cond [(atom pattern) (prep (scons pattern args) bindings)]
[(handle args) (bind pattern (map up ↑args) bindings)]
[(and (empty pattern) (empty args)) bindings]
[$T (bind (1st pattern)
(1st args)
(bind (rest pattern) (rest args) bindings))])))

(define REBIND
(lambda expr [var binding env]
(cond [(empty env) (replace ↑env ↑[[var binding]])]
[(= var (1st (1st env)))
(rplacn 2 ↑(1st env) ↑binding)]
[$T (rebind var binding (rest env))])))

(define PROMPT
(lambda expr [stream]
(block (output carriage-return stream)
(output #> stream)
(output # stream))))

(define REPLY
(lambda expr [answer stream]
(block (output carriage-return stream)
(output #> stream)
(output # stream)
(print answer stream))))

(define DEFINE
(lambda macro [label form]
̀ (block (set ,label (y-operator (lambda expr [,label] ,form)))
,↑label)))

(define Y-OPERATOR
(lambda expr [fun]
(let [[temp (lambda expr ? ?)]]
(block (replace ↑temp ↑(fun temp))
temp))))

(define EXPR (lambda expr [env-d pattern body] (ccons ’expr env-d pattern body)))
(define IMPR (lambda expr [env-d pattern body] (ccons ’impr env-d pattern body)))
(define MACRO (lambda expr [env-d pattern body] (ccons ’macro env-d pattern body)))

(define TYPE (lambda expr [x] (type x)))
(define = (lambda expr [x y] (= x y)))
(define UP (lambda expr [x] (up x)))
(define DOWN (lambda expr [x] (down x)))
(define REPLACE (lambda expr [x y] (replace x y)))

(define PCONS (lambda expr [x y] (pcons x y)))
(define CAR (lambda expr [x] (car x)))
(define CDR (lambda expr [x] (cdr x)))

(define RCONS (lambda expr x (rcons . x)))
(define SCONS (lambda expr x (scons . x)))
(define PREP (lambda expr [x y] (prep x y)))
(define LENGTH (lambda expr [x] (length x)))
(define NTH (lambda expr [x y] (nth x y)))
(define TAIL (lambda expr [x y] (tail x y)))

(define CCONS (lambda expr [k e p b] (ccons k e p b)))
(define PROCEDURE-TYPE (lambda expr [x] (procedure-type x)))
(define CENV (lambda expr [x] (cenv x)))
(define PATTERN (lambda expr [x] (pattern x)))
(define BODY (lambda expr [x] (body x)))

(define + (lambda expr [x y] (+ x y)))
(define - (lambda expr [x y] (- x y)))
(define / (lambda expr [x y] (/ x y)))
(define * (lambda expr [x y] (* x y)))

(define IF (lambda impr [prem c1 c2] primitive-impr-body))
(define SET (lambda impr [var value] primitive-impr-body))
(define LAMBDA (lambda impr [pattern body] primitive-impr-body))

(define INPUT (lambda expr [stream] (input stream)))
(define OUTPUT (lambda expr [token stream] (output token stream)))