Page Numbers: Yes X: 306 Y: 1.0" First Page: 71
Margins: Top: 1.0" Bottom: 1.1"
Heading:
APPENDIX AINTERIM 3-LISP REFERENCE MANUAL January 10, 1984
————————————————————
Appendix A. Standard Procedure Definitions
————————————————————
This appendix contains definitions for all of the standard procedures described in :4, 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.
————————————————————————————————————————————
The Reflective Processor
————————————————————————————————————————————
First a version without error detection:
(define READ-NORMALISE-PRINT
(lambda [level env stream]
(normalise (begin (printout stream level "> ")
(read stream))
env
(lambda [result-nf]
(begin (printout stream level "= " result-nf cr)
(rebind ’it result-nf global)
(read-normalise-print level env stream))))))
(define NORMALISE
(lambda [structure env cont]
(cond [(normal structure) (cont structure)]
[(atom structure) (cont (binding structure env))]
[(rail structure)
(if (null structure)
(cont structure)
(normalise (first structure) env
(lambda [first-nf]
(normalise (rest structure) env
(lambda [rest-nf]
(cont (cons first-nf rest-nf)))))))]
[(pair structure)
(normalise (pproc structure) env
(lambda [proc-nf]
(cond [(macro-closure proc-nf)
(normalise ((expander proc-nf) structure) env cont)]
[(reflective-closure proc-nf)
((de-reflect proc-nf) structure env cont)]
[(simple-closure proc-nf)
(normalise (pargs structure) env
(lambda [args-nf]
(if (primitive-closure proc-nf)
(cont ↑(↑proc-nf . ↑args-nf))
(normalise (body proc-nf)
(bind (pattern proc-nf)
args-nf
(closure-environment proc-nf))
cont))))])))])))
Now a more complex version, with full error detection:
(define READ-NORMALISE-PRINT
(lambda [level env stream]
(normalise (begin (printout stream level "> ")
(read stream))
env
(lambda [err-message err-structure err-env err-esc err-cont err-culprit err-tidbit]
(begin (printout stream "Error at level " LEVEL " of type " ERR-MESSAGE "." CR)
(printout stream "Error expression is " err-exp "." CR)
(if (not (null err-culprit))
(printout stream "Culprit is " err-culprit "." CR)
$true)
(if (not (null err-tidbit))
(printout stream "Tidbit is " err-tidbit "." CR)
$true)
(read-normalise-print level env stream)))
(lambda [result-nf]
(begin (printout stream level "= " result-nf cr)
(rebind ’it result-nf global)
(read-normalise-print level env stream))))))
(define NORMALISE
(lambda [structure env esc cont]
(cond [(normal structure) (cont structure)]
[(atom structure)
(let [[result (binding structure env)]]
(if (= result "Unbound variable")
(esc result structure env esc cont "" "")
(cont result)))]
[(rail structure)
(if (null structure)
(cont structure)
(normalise (first structure) env esc
(lambda [first-nf]
(normalise (rest structure) env esc
(lambda [rest-nf]
(cont (cons first-nf rest-nf)))))))]
[(pair structure)
(normalise (pproc structure) env esc
(lambda [proc-nf]
(cond [(macro-closure proc-nf)
(normalise ((expander proc-nf) structure) env esc cont)]
[(reflective-closure proc-nf)
((de-reflect proc-nf) structure env cont)]
[(simple-closure proc-nf)
(normalise (pargs structure) env esc
(lambda [args-nf]
(if (primitive-closure proc-nf)
(cps-error-protect ↑(↑proc-nf . ↑args-nf)
cont
(lambda [message]
(esc message structure env esc cont proc-nf args-nf)))
(let [[new-env (bind (pattern proc-nf)
args-nf
(closure-environment proc-nf))]]
(if (= new-env "Wrong number of arguments")
(esc new-env structure env esc cont proc-nf args-nf)
(normalise (body proc-nf) new-env esc cont)))))))]
[$trueRUE (ESC "Not reducible" structure env esc cont proc-nf "")] )))] )))
————————————————————————————————————————————
Processor Utilities
————————————————————————————————————————————
(define NORMAL
(lambda [s]
(let [[ts (type s)]]
(cond [(member ts [’atom ’pair]) $false]
[(member ts [’numeral ’charat ’boolean ’handle ’closure
’environment-designator ’stringer ’streamer])
$true]
[(= ts ’rail) (normal-rail s)]))))
(define NORMAL-RAIL
(lambda [rail]
(cond [(null rail) $true]
[(normal (first rail)) (normal-rail (rest rail))]
[$true $false])))
(define REDUCE
(lambda [proc args env esc cont]
(normalise ’(,proc . ,args) env esc cont)))
(define PRIMITIVE
(lambda [closure]
(member closure primitive-closures)))
;;; ???? to be checked:
(set PRIMITIVE-CLOSURES
[↑+ ↑- ↑* ↑/ ↑< ↑> ↑<= ↑>= ↑ef ↑type ↑nth ↑empty ↑tail ↑length ↑rcons ↑cons
↑scons ↑ccons ↑procedure-type ↑environment-designator ↑pattern ↑body ↑pcons
↑car ↑cdr ↑acons ↑up ↑down ↑input ↑output ↑loadfile ↑editdef])
(define DE-REFLECT
(lambda [closure] ↑(extract-simple-closure))
(define EXPANDER
(lambda [closure] ↑(extract-simple-closure))
————————————————————————————————————————————
Naming and Procedure Definition
————————————————————————————————————————————
(let [[make-lambda-closure
(lambda [call]
(let [[pattern (arg 1 call)]
[body (if (= 2 (length (pargs call))
(arg 2 call)
’(begin . ,(pargs call)))]]
(ccons env pattern body)))]]
(begin
(define LAMBDA
(rlambda [call env esc cont]
(cont (make-lambda-closure call env))))
(define MLAMBDA
(rlambda [call env esc cont]
(cont (macro-ccons (make-lambda-closure call env)))))
(define RLAMBDA
(rlambda [call env esc cont]
(cont (macro-ccons (make-lambda-closure call env))))))
(define MACROIFY (lambda [handler-function] (macro-ccons ↑handler-function)))
(define REFLECTIFY (lambda [expander-function] (reflective-ccons ↑expander-function)))
(define DEFINE
(mlambda [call]
(let [[label (arg 1 call)]
[form (arg 2 call)]]
’(begin (set ,label ,form)
,↑label))))
(define SET
(rlambda [call env esc cont]
(let [[var (arg 1 call)]
[binding (arg 2 call)]]
(normalise binding env esc
(lambda [binding-nf]
(begin (rebind var binding-nf env)
(cont binding-nf))))))
(define SETREF
(rlambda [call env esc cont]
(normalise (pargs call) env esc
(lambda [pargs-nf]
(let [[var ↑(arg 1 pargs-nf)]
[binding (arg 2 pargs-nf)]]
(begin (rebind var binding env)
(cont binding-nf)))))))
(define LET
(mlambda [call]
(let [[list (arg 1 call)]
[body (arg 2 call)]]
’((lambda ,(map 1st list) ,body) . ,(map 2nd list)))))
(define LETSEQ
(mlambda [call]
(let [[list (arg 1 call)]
[body (arg 2 call)]]
(if (null list)
body
’(let [,(first list)]
(letseq ,(rest list) ,body))))))
(define LETREC
(mlambda [call]
(let [[list (arg 1 call)]
[body (arg 2 call)]]
’((lambda ,(map first list)
(begin (begin . ,(map (lambda [x] ’(set . ,x)) list))
,body))
.,(map (lambda [x] ’’?) list))))
————————————————————————————————————————————
Control Structure Utilities
————————————————————————————————————————————
(define IF
(rlambda [call env esc cont]
(let [[args (pargs call)]]
(normalise (1st args) env esc
(lambda [premise-nf]
(normalise (ef ↑premise-nf (2nd args) (3rd args))
env
esc
cont))))))
(letrec [[EXPAND-COND
(lambda [clauses env cont]
(normalise (1st (1st clauses)) env
(lambda [premise-nf]
(if ↑premise-nf
(normalise (2nd (1st clauses)) env cont)
(cond-helper (rest clauses) env cont)))))]]
(define COND (reflectify cond-helper))
(define BLOCK-HELPER
(lambda [clauses env cont]
(if (unit clauses)
(normalise (1st clauses) env cont)
(normalise (1st clauses) env
(lambda ?
(block-helper (rest clauses) env cont))))))
(define BLOCK (reflectify block-helper))
(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) ’$true (3rd args))]]
’(letrec
[[,loop-name
(lambda ,variables
(cond
.,(append quitters
’[[$true (block ,body
(,loop-name . , next))]])))]]
(,loop-name . , init)))))
(define SELECT
(lambda macro args
(letseq
[[dummy (acons)]
[select-helper
(lambda [[choice action]]
(cond [(rail choice)
’[(member ,dummy ,choice) ,action]]
[(not (boolean choice))
’[(= ,dummy ,choice) ,action]]
[$true ’[,choice ,action]]))]]
’(let [[,dummy ,(1st args)]]
(cond . ,(map select-helper (rest args)))))))
(define SELECTQ
(lambda macro args
(letseq
[[dummy (acons)]
[selectq-helper
(lambda [[choice action]]
(cond [(atom choice)
’[(= ,dummy ,↑choice) ,action]]
[(rail choice)
’[(member ,dummy ,↑choice) ,action]]
[$true ’[,choice ,action]]))]]
’(let [[,dummy ,(1st args)]]
(cond . ,(map selectq-helper (rest args)))))))
(define CATCH
(lambda reflect [[exp] env cont]
(cont (normalise exp env id))))
(define THROW
(lambda reflect! [[exp!] env cont] exp!))
(define DELAY
(lambda macro [exp]
’(lambda [] ,exp)))
(define FORCE
(lambda [delayed-exp]
(delayed-exp)))
————————————————————————————————————————————
Vector Utilities
————————————————————————————————————————————
(define 1ST (lambda [vector] (nth 1 vector)))
(define 2ND (lambda [vector] (nth 2 vector)))
(define 3RD (lambda [vector] (nth 3 vector)))
(define 4TH (lambda [vector] (nth 4 vector)))
(define 5TH (lambda [vector] (nth 5 vector)))
(define 6TH (lambda [vector] (nth 6 vector)))
(define REST (lambda [vector] (tail 1 vector)))
(define FOOT
(lambda [vector]
(tail (length vector) vector)))
(define UNIT
(lambda [vector]
(and (not (empty vector)) (empty (rest vector)))))
(define DOUBLE
(lambda [vector]
(and (not (empty vector)) (unit (rest vector)))))
(define MEMBER
(lambda [element vector]
(cond [(empty vector) $false]
[(= element (1st vector)) $true]
[$true (member element (rest vector))])))
(define ISOMORPHIC
(lambda [e1 e2]
(cond [(not (= (type e1) (type e2))) $false]
[(= e1 e2) $true]
[(rail e1)
(or (and (empty e1) (empty e2))
(and (not (empty e1))
(not (empty e2))
(isomorphic (1st e1) (1st e2))
(isomorphic (rest e1) (rest e2))))]
[(pair e1)
(and (isomorphic (car e1) (car e2))
(isomorphic (cdr e1) (cdr e2)))]
[(closure e1)
(and (isomorphic (procedure-type e1)
(procedure-type e2))
(isomorphic (pattern e1) (pattern e2))
(isomorphic (body e1) (body e2))
(isomorphic (environment-designator e1)
(environment-designator e2)))]
[(handle e1) (isomorphic ↑e1 ↑e2)]
[$true $false])))
(define INDEX
(lambda [element vector]
(letrec
[[index-helper
(lambda [vector-tail position]
(cond [(empty vector-tail) 0]
[(= (1st vector-tail) element) position]
[$true (index-helper (rest vector-tail) (1+ position))]))]]
(index-helper vector 1))))
(define VECTOR-CONSTRUCTOR
(lambda [template]
(if (external template) scons rcons)))
(define XCONS
(lambda args
(pcons (1st args) (rcons . (rest args)))))
(define MAP
(lambda args
(cond [(empty (2nd args)) ((vector-constructor (2nd args)))]
[(double args)
(prep ((1st args) (1st (2nd args)))
(map (1st args) (rest (2nd args))))]
[$true (prep ((1st args) . (map 1st (rest args)))
(map . (prep (1st args) (map rest (rest args)))))])))
(define COPY-VECTOR
(lambda [vector]
(if (empty vector)
((vector-constructor vector))
(prep (1st vector) (copy-vector (rest vector))))))
(define CONCATENATE
(lambda [rail1 rail2]
(replace (foot rail1) rail2)))
(define APPEND
(lambda [vector1 vector2]
(if (empty vector1)
vector2
(prep (1st vector1)
(append (rest vector1) vector2)))))
(define APPEND*
(lambda args
(if (unit args)
(1st args)
(append (1st args) (append* . (rest args))))))
(define REVERSE
(letrec
[[rev (lambda [v1 v2]
(if (empty v1)
v2
(rev (rest v1) (prep (1st v1) v2))))]]
(lambda [vector]
(rev vector ((vector-constructor vector))))))
(define PUSH
(lambda [element stack]
(replace ↑stack
↑(prep element
(if (empty stack)
(scons)
(prep (1st stack) (rest stack)))))))
(define POP
(lambda [stack]
(let [[top (1st stack)]]
(block
(replace ↑stack ↑(rest stack))
top))))
————————————————————————————————————————————
Arithmetic Utilities
————————————————————————————————————————————
(define 1+ (lambda [n] (+ n 1)))
(define 1- (lambda [n] (- n 1)))
(define **
(lambda [m n]
(do [[i 0 (1+ i)]
[a 1 (* a m)]]
[[(= i n) a]])))
(define REMAINDER
(lambda [x y]
(- x (* (/ x y) y))))
(define ABS
(lambda [n]
(if (< n 0) (- n) n)))
(define MAX
(lambda numbers
(letrec
[[max2
(lambda [x y] (if (> x y) x y))]
[max-helper
(lambda [unseen-numbers maximum]
(if (empty unseen-numbers)
maximum
(max-helper (rest unseen-numbers)
(max2 maximum (1st unseen-numbers)))))]]
(max-helper (rest numbers) (1st numbers)))))
(define MIN
(lambda numbers
(letrec
[[min2
(lambda [x y] (if (< x y) x y))]
[min-helper
(lambda [unseen-numbers minimum]
(if (empty unseen-numbers)
minimum
(min-helper (rest unseen-numbers)
(min2 minimum (1st unseen-numbers)))))]]
(min-helper (rest numbers) (1st numbers)))))
(define ODD (lambda args (not (zero (remainder n 2))))
(define EVEN (lambda args (zero (remainder n 2)))
(define NEGATIVE (lambda [n] (< n 0)))
(define NON-NEGATIVE (lambda [n] (>= n 0)))
(define POSITIVE (lambda [n] (> n 0)))
(define ZERO (lambda [n] (= n 0)))
————————————————————————————————————————————
General Utilities
————————————————————————————————————————————
(define ATOM (lambda [x] (= (type x) ’atom)))
(define RAIL (lambda [x] (= (type x) ’rail)))
(define PAIR (lambda [x] (= (type x) ’pair)))
(define NUMERAL (lambda [x] (= (type x) ’numeral)))
(define HANDLE (lambda [x] (= (type x) ’handle)))
(define BOOLEAN (lambda [x] (= (type x) ’boolean)))
(define CHARAT (lambda [x] (= (type x) ’charat)))
(define CLOSURE (lambda [x] (= (type x) ’closure)))
(define STREAMER (lambda [x] (= (type x) ’streamer)))
(define NUMBER (lambda [x] (= (type x) ’number)))
(define SEQUENCE (lambda [x] (= (type x) ’sequence)))
(define TRUTH-VALUE (lambda [x] (= (type x) ’truth-value)))
(define CHARACTER (lambda [x] (= (type x) ’character)))
(define FUNCTION (lambda [x] (= (type x) ’function)))
(define STREAM (lambda [x] (= (type x) ’stream)))
(define VECTOR
(lambda [x] (member (type x) [’rail ’sequence])))
(define INTERNAL
(lambda [x]
(member (type x)
[’atom ’rail ’pair ’numeral ’handle ’boolean ’charat
’closure ’streamer])))
(define EXTERNAL
(lambda [x]
(member (type x) [’number ’sequence ’truth-value ’character
’function ’stream])))
(define CHARACTER-STRING
(lambda [s]
(cond [(or (not (sequence s)) (empty s)) $false]
[(and (unit s) (character (1st s))) $true]
[$true (and (character (1st s))
(character-string (rest s)))])))
(define ENVIRONMENT
(lambda [closure]
↑(environment-designator closure)))
(define REFERENT
(lambda reflect! [[exp! env!] env cont]
(normalise ↑exp! ↑env! cont)))
(define MACRO-EXPANDER
(lambda [macro-closure]
↑(binding ’expander (environment ↑macro-closure))))
(define ID (lambda [x] x))
(define ID* (lambda x x))
(define QUOTE (lambda reflect [[a] e c] (c ↑a)))
(define RPLACT
(lambda [n rail new-tail]
(replace (tail n rail) new-tail)))
(define RPLACN
(lambda [n rail new-element]
(replace (tail (- n 1) rail) (prep new-element (tail n rail)))))
(define RPLACA
(lambda [pair new-car]
(replace pair (pcons new-car (cdr pair)))))
(define RPLACD
(lambda [pair new-cdr]
(replace pair (pcons (car pair) new-cdr))))
(define NOT (lambda [x] (if x $false $true)))
(define AND
(lambda reflect [args env cont]
(if (rail args)
(and-helper args env cont)
(normalise args env
(lambda [args!]
(and-helper args! env cont))))))
(define AND-HELPER
(lambda [args env cont]
(if (empty args)
(cont ’$true)
(normalise (1st args) env
(lambda [premise!]
(if ↑premise!
(and-helper (rest args) env cont)
(cont ’$false)))))))
(define OR
(lambda reflect [args env cont]
(if (rail args)
(or-helper args env cont)
(normalise args env
(lambda [args!]
(or-helper args! env cont))))))
(define OR-HELPER
(lambda [args env cont]
(if (empty args)
(cont ’$false)
(normalise (1st args) env
(lambda [premise!]
(if ↑premise!
(cont ’$true)
(or-helper (rest args) env cont)))))))
————————————————————————————————————————————
Input / Ouput
————————————————————————————————————————————
(define READ (lambda [stream] (mystery))) ; Implemented, but not explained.
(define PRINT (lambda [x stream] (mystery))) ; Implemented, but not explained.
(define INTERNALISE (lambda [x] (mystery))) ; Not yet implemented.
(define EXTERNALISE (lambda [x] (mystery))) ; Not yet implemented.
(define PRINT-STRING
(lambda [string stream]
(if (empty string)
’OK
(block (output (1st string) stream)
(print-string (rest string) stream)))))
(define NEWLINE
(lambda [stream]
(output #
stream)))
(define PROMPT&READ
(lambda [level stream]
(block (newline stream)
(print ↑level stream)
(print-string "> " stream)
(read stream))))
(define PROMPT&REPLY
(lambda [answer level stream]
(block (print ↑level stream)
(print-string "= " stream)
(print answer stream))))
————————————————————————————————————————————
System
————————————————————————————————————————————
(define VERSION
(lambda []
"3-LISP version A00. May 1, 1983"))
(define LOAD
(lambda macro [filename]
’(loadfile ,↑filename)))
(define EDIT
(lambda macro [name]
’(editdef ,↑name)))
————————————————————————————————————————————
Primitive Procedures
————————————————————————————————————————————
(define TYPE (lambda [e] (type e)))
(define = (lambda entities (= . entities)))
(define EF (lambda [premise c1 c2] (ef premise c1 c2)))
(define UP (lambda [e] (up e)))
(define DOWN (lambda [s!] (down s!)))
(define REPLACE (lambda [s1 s2] (replace s1 s2)))
(define ACONS (lambda [] (acons)))
(define PCONS (lambda [s1 s2] (pcons s1 s2)))
(define CAR (lambda [pair] (car pair)))
(define CDR (lam (car pair)))
(define CDR
(define RCONS (lambda structures (rcons . structures)))
(define SCONS (lambda entities (scons . entities)))
(define PREP (lambda [e vector] (prep e vector)))
(define LENGTH (lambda [vector] (length vector)))
(define NTH (lambda [n vector] (nth n vector)))
(define TAIL (lambda [n vector] (tail n vector)))
(define EMPTY (lambda [vector] (empty vector)))
(define CCONS
(lambda [kind def-env pattern body]
(ccons kind def-env pattern body)))
(define PROCEDURE-TYPE
(lambda [closure] (procedure-type closure)))
(define ENVIRONMENT-DESIGNATOR
(lambda [closure] (environment-designator closure)))
(define PATTERN (lambda [closure] (pattern closure)))
(define BODY (lambda [closure] (body closure)))
(define + (lambda numbers (+ . numbers)))
(define - (lambda numbers (- . numbers)))
(define / (lambda [n1 n2] (/ n1 n2)))
(define * (lambda numbers (* . numbers)))
(define < (lambda numbers (< . numbers))))
(define <= (lambda numbers (<= . numbers)))
(define > (lambda numbers (> . numbers)))
(define >= (lambda numbers (>= . numbers)))
(define INPUT (lambda [stream] (input stream)))
(define OUTPUT (lambda [e stream] (output e stream)))
(define LOADFILE (lambda [file-name] (loadfile file-name)))
(define EDITDEF (lambda [procedure-name] (editdef procedure-name)))
————————————————————————————————————————————