Page Numbers: Yes X: 306 Y: 1.0" First Page: 30
Margins: Top: 1.0" Bottom: 1.3"
Heading:
STD. PROCEDURE DEFNS.3-LISP REFERENCE MANUALFebruary 1, 1983
————————————————
8. Standard Procedure Definitions
————————————————
This section contains definitions for all of the non-primitive standard procedures, and illustrates the structure of the primitive closures. Some of the definitions given here (such as for LAMBDA and DEFINE) are viciously circular, in that they use themselves (the definition of DEFINE, for example, starts out as (define DEFINE ... ), but these circular definitions are far more illuminating than the code that is actually used to construct the appropriate closures. What is true about these definitions is that once the procedures are defined, the definitions presented here will leave them semantically unchanged.
Notes:
1.There is no error handling shown; for the time being (until we have a theory of them) errors are considered to be outside the realm of the reflective processor.
2.This code obeys the conventions on identifier names presented at the end of section 4.a.
————————————————————————————————————————————
8.a. The Reflective Processor
————————————————————————————————————————————
READ-NORMALISE-PRINT:
(define READ-NORMALISE-PRINT
(lambda simple [level env stream]
(block (prompt level)
(normalise (read stream) env
(lambda simple [answer!] (reply answer! stream)))
(read-normalise-print level env stream))))
;;; However, in the near future the definition will be changed, and PROMPT and REPLY will be replaced by LEVEL-READ and LEVEL-PRINT:
(define READ-NORMALISE-PRINT
(lambda simple [level env stream]
(normalise (level-read level stream) env
(lambda simple [answer!]
(block (level-pint answer! level stream)
(read-normalise-print level env stream))))))
(define LEVEL-READ
(lambda simple [level stream]
(block (newline stream)
(print ↑level stream)
(print-string "> " stream)
(read stream))))
(define LEVEL-PRINT
(lambda simple [answer level stream]
(block (print ↑level stream)
(print-string "> " stream)
(print answer stream))))
NORMALISE, REDUCE, and NORMALISE-RAIL:
(define NORMALISE
(lambda simple [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 simple [proc args env cont]
(normalise proc env
(lambda simple [proc!]; Continuation CPROC!
(if (reflective proc!)
(↑(de-reflect proc!) args env cont)
(normalise args env
(lambda simple [args!]; Continuation CARGS!
(if (primitive proc!)
(cont ↑(↑proc! . ↑args!))
(normalise (body proc!)
(bind (pattern proc!)
args!
(environment proc!))
cont)))))))))
(define NORMALISE-RAIL
(lambda simple [rail env cont]
(if (empty rail)
(cont (rcons))
(normalise (1st rail) env
(lambda simple [first!]; Continuation CFIRST!
(normalise-rail (rest rail) env
(lambda simple [rest!]; Continuation CREST!
(cont (prep first! rest!)))))))))
————————————————————————————————————————————
8.b. Processor Utilities
————————————————————————————————————————————
NORMAL and NORMAL-RAIL:
(define NORMAL
(lambda simple [x]
(let [[tx (type x)]]
(cond [(member tx [’atom ’pair]) $F]
[(member tx [’numeral ’charat ’boolean ’handle
’closure ’streamer]) $T]
[(= tx ’rail) (normal-rail x)]))))
(define NORMAL-RAIL
(lambda simple [rail]
(cond [(empty rail) $T]
[(normal (1st rail)) (normal-rail (rest rail))]
[$T $F])))
PRIMITIVE:
(define PRIMITIVE
(lambda simple [closure]
(member closure primitive-closures)))
(set PRIMITIVE-CLOSURES
[↑+ ↑- ↑* ↑/ ↑< ↑> ↑<= ↑>= ↑ef ↑type ↑replace
↑nth ↑empty ↑tail ↑length ↑rcons ↑prep ↑scons
↑ccons ↑procedure-type ↑environment-designator
↑pattern ↑body ↑pcons ↑car ↑cdr ↑acons ↑up ↑down
↑hash ↑input ↑output ↑loadfile ↑editdef])
BIND and BINDING:
(define BINDING
(lambda simple [var env]
(if (= var (1st (1st env)))
(2nd (1st env))
(binding var (rest env)))))
(define BIND
(lambda simple [pattern args bindings]
(cond [(atom pattern) (prep [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))])))
REFLECTIVE and DE-REFLECT:
(define REFLECTIVE
(lambda simple [closure]
(= (procedure-type closure) ’reflect)))
(define DE-REFLECT
(lambda simple [closure]
(ccons ’simple
(environment-designator closure)
(pattern closure)
(body closure))))
————————————————————————————————————————————
8.c. Naming and Procedure Definition
————————————————————————————————————————————
LAMBDA:
(define LAMBDA
(lambda reflect [[kind pattern body] env cont]
(reduce kind ↑[↑env pattern body] env cont)))
LAMBDA TYPES:
(define SIMPLE
(lambda simple [def-env pattern body]
↑(ccons ’simple def-env pattern body)))
(define REFLECT
(lambda simple [def-env pattern body]
↑(ccons ’reflect def-env pattern body)))
(define MACRO
(lambda simple [def-env pattern body]
((lambda simple [expander]
(lambda reflect [args env cont]
(normalise (expander . args) env cont)))
(simple def-env pattern body))))
(define E-MACRO
(lambda simple [def-env pattern body]
(let [[expander (simple def-env pattern body)]]
(lambda reflect [args env cont]
(if (rail args)
(normalise (expander . args) env cont)
(normalise args env
(lambda simple [args!]
(normalise (expander . args!) env cont))))))))
(define E-REFLECT
(lambda simple [def-env pattern body]
(let [[fun (simple def-env pattern body)]]
(lambda reflect [args env cont]
̀(if (rail args))
(fun args env cont)
(normalise args env
(lambda simple [args!]
(fun args! env cont))))))))
(define REFLECT!
(lambda simple [def-env pattern body]
(let [[fun (simple def-env pattern body)]]
(lambda reflect [args env cont]
(normalise args env
(lambda simple [args!]
(fun args! env cont)))))))
FIXED POINT OPERATORS:
(define Y-OPERATOR
(lambda simple [fun]
(let [[temp (lambda simple ? ?)]]
(block (replace ↑temp ↑(fun temp)) temp))))
(define Y*-OPERATOR
(lambda simple funs
(let [[temps (map (lambda simple [fun] (lambda simple ? ?)) funs)]]
(map (lambda simple [temp fun]
(block (replace ↑temp ↑(fun . temps)) temp))
temps
funs))))
REFLECTIFY:
(define REFLECTIFY
(lambda simple [fun]
(reflect (environment-designator ↑fun) (pattern ↑fun) (body ↑fun))))
VARIABLE SETTING and REBINDING:
(define DEFINE
(lambda macro [label form]
̀ (block (set ,label (y-operator (lambda simple [,label] ,form)))
,↑label)))
;;; In the near future, DEFINE will be defined as follows:
(define DEFINE
(lambda macro [label form]
̀ (block (set ,label (let [[,label ’?]]
(block (set ,label ,form) ,label)))
,↑label)))
(define SET
(lambda reflect [[var binding] env cont]
(normalise binding env
(lambda simple [binding!]
(block (rebind var binding! env)
(cont ’’OK))))))
(define SETREF
(lambda reflect! [[var! binding!] env cont]
(block (rebind var binding! env)
(cont ’’OK))))
(define REBIND
(lambda simple [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))])))
LET, LETSEQ, and LETREC:
(define LET
(lambda macro [list body]
̀ ((lambda simple ,(map 1st list) ,body) . ,(map 2nd list))))
(define LETSEQ
(lambda macro [list body]
(if (empty list)
body
̀ (let [,(1st list)]
(letseq ,(rest list) ,body)))))
(define LABELS
(lambda macro [list body]
̀ ((lambda simple ,(map 1st list)
(block
(block . ,(map (lambda simple [x] ̀ (set . ,x)) list))
,body))
.,(map (lambda simple [x] ’’hucairz) list))))
;;; In the near future, LABELS will be renamed LETREC and the ’’hucairz will become ’’?:
(define LETREC
(lambda macro [list body]
̀ ((lambda simple ,(map 1st list)
(block
(block . ,(map (lambda simple [x] ̀ (set . ,x)) list))
,body))
.,(map (lambda simple [x] ’’?) list))))
————————————————————————————————————————————
8.d. Control Structure Utilities
————————————————————————————————————————————
IF and COND:
(define IF
(lambda reflect [args env cont]
((ef (rail args)
(lambda simple []
(normalise (1st args) env
(lambda simple [premise!]
(normalise (ef ↑premise! (2nd args) (3rd args))
env
cont))))
(lambda simple []
(reduce ↑ef args env cont))))))
(define COND-HELPER
(lambda simple [clauses env cont]
(normalise (1st (1st clauses)) env
(lambda simple [premise!]
(if ↑premise!
(normalise (2nd (1st clauses)) env cont)
(cond-helper (rest clauses) env cont))))))
(define COND (reflectify cond-helper))
BLOCK:
(define BLOCK-HELPER
(lambda simple [clauses env cont]
(if (unit clauses)
(normalise (1st clauses) env cont)
(normalise (1st clauses) env
(lambda simple ?
(block-helper (rest clauses) env cont))))))
(define BLOCK (reflectify block-helper))
DO:
(define DO
(lambda macro args
(let [[loop-name (acons)]
[variables (map 1st (1st args))]
[init (map 2nd (1st args))]
[next (map 3rd (1st args))]
[quitters (2nd args)]
[body (if (double args) ’$T (3rd args))]]
̀ (labels
[[,loop-name
(lambda simple ,variables
(cond
.,(append quitters
̀ [[$T (block ,body
(,loop-name . , next))]])))]]
(,loop-name . , init)))))
SELECT and SELECTQ:
(define SELECT
(lambda macro args
(letseq
[[dummy (acons)]
[select-helper
(lambda simple [[choice action]]
(cond [(rail choice)
̀ [(member ,dummy ,choice) ,action]]
[(not (boolean choice))
̀ [(= ,dummy ,choice) ,action]]
[$T ̀ [,choice ,action]]))]]
̀ (let [[,dummy ,(1st args)]]
(cond . ,(map select-helper (rest args)))))))
(define SELECTQ
(lambda macro args
(letseq
[[dummy (acons)]
[selectq-helper
(lambda simple [[choice action]]
(cond [(atom choice)
̀ [(= ,dummy ,↑choice) ,action]]
[(rail choice)
̀ [(member ,dummy ,↑choice) ,action]]
[$T ̀ [,choice ,action]]))]]
̀ (let [[,dummy ,(1st args)]]
(cond . ,(map selectq-helper (rest args)))))))
CATCH and THROW:
(define CATCH
(lambda reflect [[exp] env cont]
(cont (normalise exp env id))))
(define THROW
(lambda reflect! [[exp!] env cont] exp!))
DELAY and FORCE:
(define DELAY
(lambda macro [exp]
̀ (lambda simple [] ,exp)))
(define FORCE
(lambda simple [delayed-exp]
(delayed-exp)))