Page Numbers: Yes X: 306 Y: 1.0" First Page: 36
Margins: Top: 1.0" Bottom: 1.3"
Heading:

STANDARD PROCEDURES3-LISP REFERENCE MANUAL March 10, 1984

;;; First a version without error checking:
;;;

(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 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 ESC CONT)]
[(SIMPLE-CLOSURE PROC-NF)
(NORMALISE (PARGS STRUCTURE) ENV ESC
(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))))])))])))

;;;
;;; Then one 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)
$T)
(IF (NOT (NULL ERR-TIDBIT))
(PRINTOUT STREAM "Tidbit is " ERR-CULPRIT "." CR)
$T)
(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 ESC 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))))))]
[$TRUE
(ESC "Not reducible" STRUCTURE ENV ESC CONT PROC-NF "")] )))])