(FILECREATED "27-Sep-84 23:09:44" {ERIS}<LISPCORE>SOURCES>LLFCOMPILE.;2 21645
changes to: (VARS LLFCOMPILECOMS)
previous date: "13-FEB-83 16:38:35" {ERIS}<LISPCORE>SOURCES>LLFCOMPILE.;1)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLFCOMPILECOMS)
(RPAQQ LLFCOMPILECOMS ((DECLARE: FIRST (VARS (COMPILEATPUTDFLG)))
(VARS (\FCCODESIZE 750))
(FNS COMPST0 FCOMPILERR GROWFCCODE OP# \ARGCHECK \ARGCHECKFAIL \MAKEPSEUDOCODE
\PSEUDOCODE.REALDEF)
(FNS FCOMPILE FCOMPILE2 COMP0 COMP0DEF CEXP0 CEXPA0 CATOM0 CCON0 CFIXCON0 CPROG0 CGO0
CRETURN0 CPROG10 CPROGN0 CLAM0 CSELQ0 CCALL0 CERSET0 CCALL2 CLAM01 CADJUST0 CCALL1
CCOND0 CJUMPX JFIX0 CBYTE0)
(VARS (\FCCODEARRAY (\CODEARRAY \FCCODESIZE 0)))
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDVARS (NOFIXVARSLST GVAR← PVAR← PVARX← IVARX← FVARX← 'NIL 'T '0 '1 PVAR←↑))
(GLOBALVARS \FCCODESIZE \FCCODEARRAY))
(MACROS OP#)
(TEMPLATES OP#)
(PROP FCOMPILE CADR CAR CDR IPLUS IDIFFERENCE SUB1 EQ LISTP NEQ NLISTP NULL NOT \GETBASEPTR
ILESSP IGREATERP)
(P (MOVD? (QUOTE NILL)
(QUOTE ADDREF)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA OP#)
(NLAML)
(LAMA)))))
(DECLARE: FIRST
(RPAQQ COMPILEATPUTDFLG NIL)
)
(RPAQQ \FCCODESIZE 750)
(DEFINEQ
(COMPST0
[LAMBDA (CODE IVARS PVARS FVARS AT START COMFN)
(* lmm "13-FEB-83 15:44")
(SETQ CODE (CBYTE0 (OP# -X-)
CODE))
(PROG (NTSIZE REALSIZE STARTPC NTWORDS CA FVAROFFSET LOCALARGS STARTLOCALS LOCALSIZE
(IVARCNT (LENGTH IVARS))
(PVARCNT (LENGTH PVARS))
FVARCNT FVARS)
(SETQ FVARCNT PVARCNT)
(for X in FVARREF
do [OR (SETQ D (FASSOC (CAR X)
FVARS))
(push FVARS (SETQ D (CONS (CAR X)
(PROG1 FVARCNT (add FVARCNT 1]
(CODESETA \FCCODEARRAY (CADR X)
(LLSH (CDR D)
1)))
(SETQ NTWORDS (LLSH (SETQ NTSIZE (CEIL (IPLUS IVARCNT FVARCNT 1)
WORDSPERQUAD))
1))
(SETQ STARTPC (UNFOLD (IPLUS (fetch (CODEARRAY OVERHEADWORDS) of T)
NTWORDS)
BYTESPERWORD))
(* initial pc for the function: after fixed header and double nametable)
(SETQ REALSIZE (CEIL (IPLUS STARTPC CODE)
BYTESPERQUAD))
(SETQ CA (\CODEARRAY REALSIZE (CEIL (ADD1 (FOLDHI STARTPC BYTESPERCELL))
CELLSPERQUAD)))
(PROG ((NT1 (ADD1 (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T)
BYTESPERWORD)))
(NTBSZ (UNFOLD NTSIZE BYTESPERWORD)))
(for X in PVARS
do (\FIXCODENUM CA NT1 (\ATOMVALINDEX (CAR X)))
(\FIXCODENUM CA (IPLUS NT1 NTBSZ)
(IPLUS PVARCODE (CDR X)))
(add NT1 BYTESPERWORD))
(for X in IVARS
do (\FIXCODENUM CA NT1 (\ATOMVALINDEX (CAR X)))
(\FIXCODENUM CA (IPLUS NT1 NTBSZ)
(IPLUS IVARCODE (CDR X)))
(add NT1 BYTESPERWORD))
(SETQ FVAROFFSET (FOLDLO NT1 BYTESPERWORD))
(for X in (REVERSE FVARS)
do (\FIXCODENUM CA NT1 (\ATOMVALINDEX (CAR X)))
(\FIXCODENUM CA (IPLUS NT1 NTBSZ)
(IPLUS FVARCODE (CDR X)))
(add NT1 BYTESPERWORD)))
(PROGN (* Fill in function header)
(replace (CODEARRAY NA) of CA with (COND
((EQ AT 2)
-1)
(T IVARCNT)))
(replace (CODEARRAY PV) of CA with (SUB1 (FOLDHI FVARCNT CELLSPERQUAD)))
(replace (CODEARRAY STARTPC) of CA with STARTPC)
(replace (CODEARRAY ARGTYPE) of CA with AT)
(replace (CODEARRAY FRAMENAME) of CA with COMFN)
(replace (CODEARRAY NTSIZE) of CA with NTSIZE)
(replace (CODEARRAY NLOCALS) of CA with PVARCNT)
(replace (CODEARRAY FVAROFFSET) of CA with FVAROFFSET)
(replace (CODEARRAY FIXED) of CA with T))
(while (ILESSP START CODE)
do (CODESETA CA STARTPC (CODELT \FCCODEARRAY START))
(add START 1)
(add STARTPC 1))
(RETURN CA])
(FCOMPILERR
[LAMBDA (X Y) (* lmm "18-FEB-82 22:19")
(printout T X Y T)
(RETFROM RETLOC])
(GROWFCCODE
[LAMBDA (GROWTH) (* lmm "17-FEB-82 15:39")
(PROG ((CA (\CODEARRAY (SETQ GROWTH (IPLUS \FCCODESIZE GROWTH))
0)))
(for J from 0 while (ILESSP J \FCCODESIZE) do (CODESETA CA J (CODELT \FCCODEARRAY J)))
(SETQ \FCCODEARRAY CA)
(SETQ \FCCODESIZE GROWTH])
(OP#
[NLAMBDA X (* lmm "12-FEB-82 23:50")
(CAR (\FINDOP (CAR X])
(\ARGCHECK
[LAMBDA (X TYP ARGS) (* edited: "19-FEB-82 15:57")
(* could do in line with (X COPY CAR (QUOTE TYP) EQ TJUMP+2 FAIL CDR COPY LISTP TJUMP+2 FAIL CAR
(QUOTE ARGS) EQUAL TJUMP+2 FAIL))
(COND
((OR (NEQ (CAR X)
TYP)
(NLISTP (CDR X))
(NOT (EQUAL (CADR X)
ARGS)))
(\ARGCHECKFAIL X])
(\ARGCHECKFAIL
[LAMBDA (LAM) (* edited: "19-FEB-82 16:35")
(PROG ((FN (STKNAME -3)))
(PUTD FN (GETD FN))
(LISPERROR "ILLEGAL ARG" LAM])
(\MAKEPSEUDOCODE
[LAMBDA (LAM TOPFN) (* edited: "19-FEB-82 16:25")
(AND COMPILEATPUTDFLG (DEFINEDP (QUOTE COMP0DEF))
(PROG ((RETLOC (QUOTE \MAKEPSEUDOCODE)))
(RETURN (AND (LISTP LAM)
(LISTP (CDR LAM))
(SELECTQ (CAR LAM)
([LAMBDA NLAMBDA]
(fetch (ARRAYP BASE)
of (COMP0DEF TOPFN
[LIST (CAR LAM)
(CADR LAM)
[LIST (QUOTE \ARGCHECK)
(KWOTE LAM)
(KWOTE (CAR LAM))
(KWOTE (COND
((LISTP (CADR LAM))
(APPEND (CADR LAM)))
(T (CADR LAM]
(SELECTQ COMPILEATPUTDFLG
(ALL (CONS (QUOTE PROGN)
(CDDR LAM)))
(LIST (QUOTE \EVPROGN)
(KWOTE (CDDR LAM]
0)))
NIL])
(\PSEUDOCODE.REALDEF
[LAMBDA (FNH) (* edited: "19-FEB-82 16:24")
(AND FNH (\GETBASEPTR FNH (FOLDLO (fetch (FNHEADER STARTPC) of FNH)
BYTESPERWORD])
)
(DEFINEQ
(FCOMPILE
[LAMBDA (FNLST) (* lmm "17-FEB-82 11:47")
(* Note that the "mini-compiler" is machine dependent in two ways: it knows the all the opcodes and it uses
knowledge about the representation of code arrays in COMPST0 and CBYTE0)
(PROG (EFF RETF PREDF)
(DECLARE (SPECVARS EFF RETF PREDF))
(RETURN (for X inside FNLST bind DEF collect (OR (AND (LITATOM X)
(EXPRP (SETQ DEF (VIRGINFN X T)))
(FCOMPILE2 X DEF))
(CONS X (QUOTE (not compilable])
(FCOMPILE2
[LAMBDA (TOPFN DEF) (* lmm "18-FEB-82 22:18")
(PROG ((RETLOC (QUOTE FCOMPILE2)))
(RETURN (COMP0 TOPFN DEF 0])
(COMP0
[LAMBDA (COMFN DEF START) (* lmm "18-FEB-82 22:13")
(DPUTCODE COMFN (COMP0DEF COMFN DEF START))
COMFN])
(COMP0DEF
[LAMBDA (COMFN DEF START) (* lmm "18-FEB-82 22:18")
(PROG (IVARS PVARS FVARS (LBL NIL)
(INPROG NIL)
(IVARN 0)
(VL (CADR DEF))
(AT (ARGTYPE DEF))
(PVARN 0)
CURRENTPVARS
(FVARREF))
(SETQ DEF (CDDR DEF))
[OR (LISTP VL)
(NULL VL)
(COND
((NEQ AT 2) (* NLAMBDA*)
(SETQ VL (LIST VL)))
(T [OR (EQ VL (QUOTE NOBIND))
(SETQ DEF (LIST (LIST (CONS (QUOTE LAMBDA)
(CONS (LIST VL)
DEF))
(QUOTE (\MYARGCOUNT]
(SETQ VL]
[MAPC VL (FUNCTION (LAMBDA (V)
(push IVARS (CONS V (PROG1 IVARN (add IVARN 1]
(RETURN (COMPST0 (CBYTE0 (OP# RETURN)
(CPROGN0 DEF START))
IVARS PVARS FVARREF AT START COMFN])
(CEXP0
[LAMBDA (E CODE) (* lmm "12-FEB-82 23:11")
(COND
((LISTP E)
(CCALL0 E CODE))
(T (CATOM0 E CODE])
(CEXPA0
[LAMBDA (ARGCNT E CODE) (* lmm "13-FEB-82 14:15")
(COND
((LISTP E)
(CCALL0 E CODE))
(T (CATOM0 E CODE])
(CATOM0
[LAMBDA (VAR CODE SET) (* lmm "17-FEB-82 12:31")
(PROG (D)
(RETURN (COND
[(SETQ D (CDR (FASSOC VAR IVARS)))
(COND
(SET (CBYTE0 (LLSH D 1)
(CBYTE0 (OP# IVARX←)
CODE)))
((IGEQ D 7)
(CBYTE0 (LLSH D 1)
(CBYTE0 (OP# IVARX)
CODE)))
(T (CBYTE0 (IPLUS (OP# IVAR)
D)
CODE]
[(SETQ D (CDR (FASSOC VAR CURRENTPVARS)))
(COND
(SET (CBYTE0 (LLSH D 1)
(CBYTE0 (OP# PVARX←)
CODE)))
((IGEQ D 7)
(CBYTE0 (LLSH D 1)
(CBYTE0 (OP# PVARX)
CODE)))
(T (CBYTE0 (IPLUS (OP# PVAR)
D)
CODE]
((EQ VAR T)
(CBYTE0 (OP# 'T)
CODE))
((NULL VAR)
(CBYTE0 (OP# 'NIL)
CODE))
((LITATOM VAR)
[push FVARREF (LIST VAR (SETQ CODE (CBYTE0 (COND
(SET (OP# FVARX←))
(T (OP# FVARX)))
CODE]
(CBYTE0 0 CODE))
(T (CCON0 VAR CODE])
(CCON0
[LAMBDA (X CODE) (* lmm "13-FEB-83 15:53")
(SELECTQ X
(NIL (CBYTE0 (OP# 'NIL)
CODE))
(T (CBYTE0 (OP# 'T)
CODE))
(0 (CBYTE0 (OP# '0)
CODE))
(1 (CBYTE0 (OP# '1)
CODE))
(COND
[(LITATOM X)
(PROG ((D (\ATOMPNAMEINDEX X)))
(RETURN (CBYTE0 (LOGAND D 377Q)
(CBYTE0 (LRSH D 10Q)
(CBYTE0 (OP# ACONST)
CODE]
[(AND (NUMBERP X)
(IGREATERP X -400Q)
(ILEQ X 177777Q))
(COND
((IGREATERP 0 X)
(CBYTE0 (IPLUS 400Q X)
(CBYTE0 (OP# SNIC)
CODE)))
((ILEQ X 377Q)
(CBYTE0 X (CBYTE0 (OP# SIC)
CODE)))
(T (CBYTE0 (LOGAND X 377Q)
(CBYTE0 (LRSH X 10Q)
(CBYTE0 (OP# SICX)
CODE]
(T (CFIXCON0 X (CBYTE0 0 (CBYTE0 0 (CBYTE0 0 (CBYTE0 (OP# GCONST)
CODE])
(CFIXCON0
[LAMBDA (CON LOC CODE) (* lmm "17-FEB-82 13:33")
(\FIXCODEPTR \FCCODEARRAY (SUB1 LOC)
CON)
LOC])
(CPROG0
[LAMBDA (VARS BODY CODE) (* lmm " 3-FEB-80 22:23")
(COND
(VARS (CEXP0 [CONS (LIST (QUOTE LAMBDA)
[MAPCAR VARS (FUNCTION (LAMBDA (X)
(COND
((LISTP X)
(CAR X))
(T X]
(CONS (QUOTE PROG)
(CONS NIL BODY)))
(MAPCAR VARS (FUNCTION (LAMBDA (X)
(COND
((LISTP X)
(CADR X]
CODE))
(T (PROG ([LBL (MAPCONC BODY (FUNCTION (LAMBDA (X)
(COND
((LITATOM X)
(LIST (LIST X NIL]
(INPROG T)
(ARGCNT NIL)
RRL)
[SETQ CODE (CBYTE0 0 (CBYTE0 0 (CBYTE0 (OP# BIND)
CODE]
[MAPC BODY (FUNCTION (LAMBDA (X)
(SETQ CODE (COND
((LITATOM X)
(RPLACA (CDR (FASSOC X LBL))
CODE)
CODE)
(T (CBYTE0 (OP# POP)
(CEXP0 X CODE]
[MAPC LBL (FUNCTION (LAMBDA (R)
(JFIX0 (CDDR R)
(CADR R]
(RETURN (CBYTE0 (OP# UNBIND)
(JFIX0 RRL (CBYTE0 (OP# 'NIL)
CODE])
(CGO0
[LAMBDA (A CODE) (* lmm "17-FEB-82 15:41")
(PROG ((D (FASSOC A LBL)))
[COND
((OR (NULL D)
ARGCNT)
(FCOMPILERR A (QUOTE "- can't handle GO"]
[SETQ CODE (CBYTE0 0 (CBYTE0 0 (CBYTE0 (OP# JUMPXX)
CODE]
(NCONC1 D CODE)
(RETURN CODE])
(CRETURN0
[LAMBDA (L CODE) (* lmm "17-FEB-82 11:49")
(OR INPROG (FCOMPILERR L (QUOTE "- illegal RETURN")))
[SETQ CODE (CBYTE0 0 (CBYTE0 0 (CBYTE0 (OP# JUMPXX)
(CPROG10 L CODE]
(SETQ RRL (CONS CODE RRL))
CODE])
(CPROG10
[LAMBDA (L CODE) (* lmm "13-FEB-82 14:17")
(SETQ CODE (CEXP0 (CAR L)
CODE))
[MAPC (CDR L)
(FUNCTION (LAMBDA (X)
(SETQ CODE (CBYTE0 (OP# POP)
(CEXPA0 1 X CODE]
CODE])
(CPROGN0
[LAMBDA (L CODE) (* lmm " 3-FEB-80 21:46")
(PROG NIL
LP (COND
((CDR L)
[COND
((NEQ (CAR (LISTP (CAR L)))
(QUOTE *))
(SETQ CODE (CBYTE0 (OP# POP)
(CEXP0 (CAR L)
CODE]
(SETQ L (CDR L))
(GO LP)))
(RETURN (CEXP0 (CAR L)
CODE])
(CLAM0
[LAMBDA (DEF CODE) (* lpd "18-APR-77 13:15")
(COMP0 (PACK (LIST COMFN (GENSYM)))
DEF CODE])
(CSELQ0
[LAMBDA (X CL CODE) (* lmm " 3-FEB-80 21:59")
[COND
((NOT (LITATOM X))
(SETQ CODE (CBYTE0 (OP# POP)
(CEXP0 (LIST (QUOTE SETQ)
(QUOTE \SELECTQVALUE)
X)
CODE)))
(SETQ X (QUOTE \SELECTQVALUE]
(CCOND0 [MAPLIST CL (FUNCTION (LAMBDA (Y)
(COND
((CDR Y)
(CONS (LIST (COND
((NLISTP (CAAR Y))
(QUOTE EQ))
(T (QUOTE FMEMB)))
X
(KWOTE (CAAR Y)))
(CDAR Y)))
(T (LIST T (CAR Y]
CODE])
(CCALL0
[LAMBDA (FORM CODE) (* lmm "18-FEB-82 22:10")
(PROG ((ARGS (CDR FORM))
(FN (CAR FORM)))
(RETURN
(SELECTQ
(ARGTYPE FN)
(0 (SELECTQ FN
(RETURN (CRETURN0 ARGS CODE))
(CCALL1 FN ARGS CODE)))
[3 (SELECTQ FN
(SETQ (CATOM0 (CAR ARGS)
(CEXP0 (CADR ARGS)
CODE)
T))
((QUOTE *)
(CCON0 (CAR ARGS)
CODE))
(COND (CCOND0 ARGS CODE))
[AND (COND
((CDR ARGS)
(CCOND0 [LIST (LIST (CAR ARGS)
(CONS (QUOTE AND)
(CDR ARGS]
CODE))
(ARGS (CEXP0 (CAR ARGS)
CODE))
(T (CBYTE0 (OP# 'T)
CODE]
(OR (CCOND0 (MAPCAR ARGS (FUNCTION LIST))
CODE))
(SELECTQ (CSELQ0 (CAR ARGS)
(CDR ARGS)
CODE))
(PROG (CPROG0 (CAR ARGS)
(CDR ARGS)
CODE))
(GO (CGO0 (CAR ARGS)
CODE))
(PROGN (CPROGN0 ARGS CODE))
(PROG1 (CPROG10 ARGS CODE))
(COND
([NOT (EQUAL FORM (SETQ FORM (EXPANDMACRO FORM T]
(CEXP0 FORM CODE))
(T (CCALL2 FN 1 (CCON0 ARGS CODE]
[1 (COND
((AND (EQ FN (QUOTE FUNCTION))
(NULL (CDR ARGS)))
(CCON0 (COND
((LITATOM (CAR ARGS))
(CAR ARGS))
(T (CLAM0 (CAR ARGS)
CODE)))
CODE))
([NOT (EQUAL FORM (SETQ FORM (EXPANDMACRO FORM T]
(CEXP0 FORM CODE))
(T (PROG ((ARGCNT 0))
[MAPC ARGS (FUNCTION (LAMBDA (X)
(SETQ CODE (CCON0 X CODE))
(SETQ ARGCNT (ADD1 ARGCNT]
(RETURN (CCALL2 FN ARGCNT CODE]
[NIL (* NO DEF)
(SELECTQ
FN
(.ERRSETQ. (CERSET0 (CAR ARGS)
(CADR ARGS)))
(COND
([NOT (EQUAL FORM (SETQ FORM (EXPANDMACRO FORM T]
(CEXP0 FORM CODE))
([AND COMPILEUSERFN
(NOT (EQUAL FORM (SETQ FORM
(PROG [(FN TOPFN)
(OTHERVARS (NCONC (MAPCAR IVARS
(FUNCTION CAR))
(MAPCAR PVARS
(FUNCTION CAR]
(RETURN (OR (APPLY* COMPILEUSERFN (CDR FORM)
FORM)
FORM]
(CEXP0 FORM CODE))
(T (CCALL1 FN ARGS CODE))
(T (CCALL2 (QUOTE \EVALFORM)
1
(CCON0 FORM CODE]
(2 (CCALL1 FN ARGS CODE))
(SHOULDNT])
(CERSET0
[LAMBDA (FORM FLG) (* lmm "17-FEB-82 12:46")
(CCALL2 (QUOTE ERRORSET)
2
(CCON0 FLG (CCON0 [COND
((AND (NULL (CDR FORM))
(LITATOM (CAR FORM)))
FORM)
(T (LIST (CLAM0 (LIST (QUOTE LAMBDA)
NIL FORM)
CODE]
CODE])
(CCALL2
[LAMBDA (FN ARGCNT CODE) (* lmm "13-FEB-83 15:54")
(PROG (TEM)
[COND
[(LITATOM FN)
(COND
((SETQ TEM (GETPROP FN (QUOTE FCOMPILE)))
(COND
((LISTP TEM)
(SETQ CODE (CADJUST0 ARGCNT (CAR TEM)
CODE))
[MAPC (CDR TEM)
(FUNCTION (LAMBDA (X)
(SETQ CODE (CBYTE0 (CAR (\FINDOP X))
CODE]
(RETURN CODE))
((IGREATERP ARGCNT 0)
(FRPTQ (SUB1 ARGCNT)
(SETQ CODE (CBYTE0 (CAR (\FINDOP TEM))
CODE)))
(RETURN CODE]
((EQ (CAR FN)
(QUOTE LAMBDA))
(RETURN (CLAM01 FN ARGCNT CODE)))
(T (SETQ FN (CLAM0 FN CODE]
(SETQ FN (\ATOMDEFINDEX FN))
(RETURN (CBYTE0 (LOGAND FN 377Q)
(CBYTE0 (LRSH FN 10Q)
(CBYTE0 (SELECTQ ARGCNT
(3 (OP# FN3))
(2 (OP# FN2))
(1 (OP# FN1))
(4 (OP# FN4))
(0 (OP# FN0))
(PROGN (SETQ CODE (CBYTE0 (OP# FNX)
CODE))
ARGCNT))
CODE])
(CLAM01
[LAMBDA (FN ARGCNT CODE) (* lmm "17-FEB-82 00:30")
(SETQ CODE (CADJUST0 ARGCNT (SETQ ARGCNT (LENGTH (CADR FN)))
CODE))
(COND
((EQ ARGCNT 0)
(CPROGN0 (CDDR FN)
CODE))
(T (PROG ((CURRENTPVARS CURRENTPVARS))
[MAPC (CADR FN)
(FUNCTION (LAMBDA (X)
(push CURRENTPVARS (CAR (push PVARS (CONS X (PROG1 PVARN (add PVARN 1]
(RETURN (CBYTE0 (OP# UNBIND)
(CPROGN0 (CDDR FN)
(CBYTE0 (SUB1 PVARN)
(CBYTE0 ARGCNT (CBYTE0 (OP# BIND)
CODE])
(CADJUST0
[LAMBDA (NHAVE NWANT CODE) (* lmm "17-FEB-82 00:01")
(FRPTQ (IDIFFERENCE NHAVE NWANT)
(SETQ CODE (CBYTE0 (OP# POP)
CODE)))
(FRPTQ (IDIFFERENCE NWANT NHAVE)
(SETQ CODE (CBYTE0 (OP# 'NIL)
CODE)))
CODE])
(CCALL1
[LAMBDA (FN ARGS CODE) (* lmm "13-FEB-82 14:13")
(PROG ((ARGCNT 0))
[MAPC ARGS (FUNCTION (LAMBDA (X)
(SETQ CODE (CEXP0 X CODE))
(SETQ ARGCNT (ADD1 ARGCNT]
(RETURN (CCALL2 FN ARGCNT CODE])
(CCOND0
[LAMBDA (CLAUSES CODE) (* lmm "18-FEB-82 21:43")
(PROG (R J)
LP [COND
((NULL CLAUSES)
(RETURN (JFIX0 R (CBYTE0 (OP# 'NIL)
CODE]
(SETQ CODE (CEXP0 (CAAR CLAUSES)
CODE))
[push R (SETQ CODE (COND
[(CDAR CLAUSES)
(SETQ J (CJUMPX (CBYTE0 (IPLUS (OP# TJUMP)
2)
CODE)))
(JFIX0 (LIST J)
(CJUMPX (CPROGN0 (CDAR CLAUSES)
J]
(T (CJUMPX (CBYTE0 (IPLUS (OP# JUMP)
2)
(CBYTE0 3 (CBYTE0 (OP# NTJUMPX)
CODE]
(SETQ CLAUSES (CDR CLAUSES))
(GO LP])
(CJUMPX
[LAMBDA (CODE) (* lmm "18-FEB-82 21:42")
(CBYTE0 0 (CBYTE0 0 (CBYTE0 (OP# JUMPXX)
CODE])
(JFIX0
[LAMBDA (REFS CODE) (* lmm "12-FEB-82 23:18")
[MAPC REFS (FUNCTION (LAMBDA (C)
(SETQ C (SUB1 C))
(PROG [(D (IDIFFERENCE CODE (IDIFFERENCE C 2]
(CODESETA \FCCODEARRAY C (LOGAND D 255))
(CODESETA \FCCODEARRAY (SUB1 C)
(LRSH (LOGAND D 65280)
8]
CODE])
(CBYTE0
[LAMBDA (BYTE I) (* lmm "17-FEB-82 15:39")
(COND
((IGEQ I \FCCODESIZE)
(GROWFCCODE 100)))
(CODESETA \FCCODEARRAY I BYTE)
(ADD1 I])
)
(RPAQ \FCCODEARRAY (\CODEARRAY \FCCODESIZE 0))
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDTOVAR NOFIXVARSLST GVAR← PVAR← PVARX← IVARX← FVARX← 'NIL 'T '0 '1 PVAR←↑)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \FCCODESIZE \FCCODEARRAY)
)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS OP# MACRO (X
(CAR (\FINDOP (CAR X)))))
)
(SETTEMPLATE (QUOTE OP#)
(QUOTE (NIL)))
(PUTPROPS CADR FCOMPILE (1 CDR CAR))
(PUTPROPS CAR FCOMPILE (1 CAR))
(PUTPROPS CDR FCOMPILE (1 CDR))
(PUTPROPS IPLUS FCOMPILE IPLUS2)
(PUTPROPS IDIFFERENCE FCOMPILE (2 IDIFFERENCE))
(PUTPROPS SUB1 FCOMPILE (1 '1 IDIFFERENCE))
(PUTPROPS EQ FCOMPILE (2 EQ))
(PUTPROPS LISTP FCOMPILE (1 LISTP))
(PUTPROPS NEQ FCOMPILE (2 EQ 'NIL EQ))
(PUTPROPS NLISTP FCOMPILE (1 LISTP 'NIL EQ))
(PUTPROPS NULL FCOMPILE (1 'NIL EQ))
(PUTPROPS NOT FCOMPILE (1 'NIL EQ))
(PUTPROPS \GETBASEPTR FCOMPILE
(2 ADDBASE GETBASEPTR.N 0))
(PUTPROPS ILESSP FCOMPILE (2 SWAP IGREATERP))
(PUTPROPS IGREATERP FCOMPILE (2 IGREATERP))
(MOVD? (QUOTE NILL)
(QUOTE ADDREF))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA OP#)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS LLFCOMPILE COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1358 6525 (COMPST0 1368 . 4226) (FCOMPILERR 4228 . 4357) (GROWFCCODE 4359 . 4727) (OP#
4729 . 4829) (\ARGCHECK 4831 . 5224) (\ARGCHECKFAIL 5226 . 5440) (\MAKEPSEUDOCODE 5442 . 6297) (
\PSEUDOCODE.REALDEF 6299 . 6523)) (6526 20218 (FCOMPILE 6536 . 7131) (FCOMPILE2 7133 . 7294) (COMP0
7296 . 7435) (COMP0DEF 7437 . 8223) (CEXP0 8225 . 8379) (CEXPA0 8381 . 8536) (CATOM0 8538 . 9642) (
CCON0 9644 . 10647) (CFIXCON0 10649 . 10812) (CPROG0 10814 . 11877) (CGO0 11879 . 12251) (CRETURN0
12253 . 12562) (CPROG10 12564 . 12815) (CPROGN0 12817 . 13173) (CLAM0 13175 . 13309) (CSELQ0 13311 .
13848) (CCALL0 13850 . 16233) (CERSET0 16235 . 16582) (CCALL2 16584 . 17654) (CLAM01 17656 . 18270) (
CADJUST0 18272 . 18552) (CCALL1 18554 . 18813) (CCOND0 18815 . 19520) (CJUMPX 19522 . 19670) (JFIX0
19672 . 20001) (CBYTE0 20003 . 20216)))))
STOP