(FILECREATED " 2-Jun-86 22:17:10" {ERIS}<LISPCORE>SOURCES>DLAP.;60 105711
changes to: (VARS DLAPCOMS)
previous date: "23-May-86 17:10:33" {ERIS}<LISPCORE>SOURCES>DLAP.;59)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved. The
following program was created in 1981 but has not been published within the meaning of the copyright
law, is furnished under license, and may not be used, copied and/or disclosed except in accordance
with the terms of said license.)
(PRETTYCOMPRINT DLAPCOMS)
(RPAQQ DLAPCOMS
((FNS C.FLOATBOX C.FLOATUNBOX DASSEM.DASSEM DASSEM.DWRITEFN DASSEM.SAVELOCALVARS
DASSEM.DSTOREFNDEF DASSEM.DPRINTLAP DASSEM.EQCONSTANTP DASSEM.MATCHVARS DASSEM.COUNTVARS
DASSEM.CANSHAREBINDING)
(CONSTANTS NARGMAX NLOCALMAX NFREEMAX)
(FNS DASSEM.DASMBIND DASSEM.DSTOREFN DASSEM.ASMAJ)
(VARS (EMFLAG)
(COMPILEMODE (QUOTE D)))
(PROP (MOPVAL AJSIZES)
JUMP FJUMP TJUMP NTJUMP NFJUMP)
(PROP DOPVAL * DOPVALS)
(VARS CONSTOPS (COMPILE.ARG.FAST.FLG)
(IPLUSNFLG))
(ADDVARS (8BITEXTS DCOM))
(ADDVARS (MACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO))
(ADDVARS (COMPILERMACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO))
(VARS (BYTEASSEMFN (QUOTE DASSEM.DASSEM))
(MAXBVALS 15)
(COMPILE.EXT (QUOTE DCOM))
(BYTECOMPFLG T)
(SELECTQFMEMB NIL)
(LAMBDANOBIND T)
(SELECTVARTYPES (QUOTE (AVAR HVAR)))
[CONST.FNS (QUOTE ((NIL (1 CAR (CONST))
(1 CDR (CONST))
(1 NULL (CONST . T))
(2 EQ (FN 1 . NULL)))
(0 (2 ITIMES2 (POP)
(CONST . 0))
(2 LOGAND2 (POP)
(CONST . 0))
(2 IPLUS (FN 1 . FIX))
(2 LOGOR2 (FN 1 . FIX))
(2 \ADDBASE))
(1 (2 ITIMES2 (FN 1 . FIX]
(MERGEFRAMEFLG T)
(MERGEFRAMEMAX 2)
(CLEANFNLIST (QUOTE (NTYPX EQ AND OR CONS LIST FMEMB MEMB GETP SUB1 ADD1 ZEROP ELT
ILESSP LLSH LRSH IPLUS IDIFFERENCE \ARG0 \CALLME GETHASH
\ADDBASE)))
(OPCODEPROP (QUOTE DOPVAL))
(VCONDITIONALS (QUOTE (ARRAYP FIXP FLOATP LISTP SMALLP STACKP NUMBERP)))
(CONDITIONALS (QUOTE (EQ IGREATERP NULL GREATERP LESSP ILESSP)))
(CONSTFNS (QUOTE (IPLUS SUB1 ADD1 ZEROP LLSH LRSH IDIFFERENCE)))
(MAXARGS 80)
(XVARFLG NIL)
(NOFREEVARFNS (QUOTE (RPLACA RPLACD PUTHASH SETA)))
(CLEANFNTEST (QUOTE DASSEM.CLEANFNTEST))
(EQCONSTFN (QUOTE DASSEM.EQCONSTANTP)))
(ADDVARS (NUMBERFNS LLSH1 LRSH1 LLSH8 LRSH8))
(CONSTANTS (SHALLOWFLG NIL)
(SPAGHETTIFLG T))
(FNS DASSEM.CLEANFNTEST)
(PROP DMACRO ATOM EVALV FGETD FGREATERP FLESSP FMEMB FRPLACA FRPLACD GETATOMVAL GETD GREATERP
IGREATERP ILESSP LESSP LIST LITATOM LLSH LRSH MINUSP NTHCHARCODE PRINTNUM RESETSAVE
RESETVAR RESETVARS RPLACD SETATOMVAL SYSTEMTYPE \FLOATBOX \FLOATUNBOX IEQP FASSOC)
(FNS COMP.RPLACD COMP.SHIFT COMP.COMPARENUM COMP.GETD COMP.FMEMB)
(PROP PROPTYPE DMACRO)
(COMS (* COMP.GETBASE)
(PROP DMACRO \GETBASE \GETBASEBYTE \GETBASEPTR \HILOC \LOLOC \PUTBASE \PUTBASEBYTE
\PUTBASEPTR \RPLPTR \VAG2 \GETBITS \PUTBITS \PUTBASEFIXP \GETBASEFIXP)
(FNS COMP.GETBASE COMP.GETBASEBITS))
(COMS (FNS COMP.SPREADFN)
(PROP DMACRO APPEND NCONC))
(COMS (* CAPPLYFN)
(PROP DMACRO NILAPPLY .PUSHNILS. SPREADAPPLY .SPREAD. SPREADAPPLY* .EVALFORM.
.CALLAFTERPUSHINGNILS. APPLY*)
(PROP DOPVAL .SPREADCONS. .SWAPNIL.)
(FNS COMP.PUSHNILS COMP.SPREAD COMP.EVALFORM COMP.PUSHCALL COMP.APPLY*))
(COMS (* for ERRORSET ARG and SETARG)
(PROP DMACRO .ERRSETQ. ARG SETARG NAMEDLET)
(FNS COMP.ERRORSET COMP.ARG COMP.SETARG COMP.NAMEDLET))
(COMS (PROP DMACRO LOADTIMECONSTANT)
(VARS LOADTIMECONSTANTMARKER))
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS DASM)
(GLOBALVARS FVINDEXHARRAY)
(MACROS PARENTP AST OPCOUNT)
(MACROS CHECKRANGE)
DONTEVAL@LOAD
(FILES (LOADCOMP)
BYTECOMPILER LLCODE))))
(DEFINEQ
(C.FLOATBOX
[LAMBDA (A) (* lmm
"29-Dec-84 11:39")
(SELECTQ COMPILE.CONTEXT
(EFFECT (COMP.VALN A (QUOTE EFFECT)))
(PROGN (COMP.VAL1 A)
(COMP.FLOATBOX])
(C.FLOATUNBOX
[LAMBDA (A) (* lmm
"29-Dec-84 11:44")
(SELECTQ COMPILE.CONTEXT
(EFFECT (COMP.VALN A (QUOTE EFFECT)))
(COMP.VAL1 A (QUOTE (UNBOXED . FLOAT])
(DASSEM.DASSEM
[LAMBDA (FN CC) (* lmm
" 2-Jan-85 01:24")
(PROG ((ARGTYPE (fetch COMTYPE of CC))
(ARGS (fetch ARGS of CC))
(CODE (fetch CODE of CC))
NARGS NLOCALS FREEVARS NFREEVARS ORG CD (VARCOUNT 0)
LOCALS
(FRAMENAME FN))
(DECLARE (SPECVARS VARCOUNT FRAMES CD CODELOC))
(fetch (DASM CLEAR) of T)
(COND
((AND (EQ ARGTYPE 2)
ARGS)
[push CODE (create OP
OPNAME ←(QUOTE FN)
OPARG ←(QUOTE (0 . \MYARGCOUNT)))
(create OP
OPNAME ←(QUOTE BIND)
OPARG ←(CONS NIL (SETQ ARGS (fetch TOPFRAME of CC]
(replace NVALS of ARGS with 1)
(replace NNILS of ARGS with 0)
(SETQ ARGS NIL)
(SETQ NARGS 0))
(T (DASSEM.COUNTVARS ARGS)
(SETQ NARGS VARCOUNT)))
(PROGN (PROG ((LL CODE)
X A D FREELST FRAMES)
(DECLARE (SPECVARS FRAMES))
LP (COND
((NULL LL)
(GO OUT)))
[SETQ A (fetch OPARG of (SETQ X (CAR LL]
PR (SELECTQ (fetch OPNAME of X)
(CONST (COND
((EQ (fetch OPNAME of (SETQ D (CADR LL)))
(QUOTE FN))
(SELECTQ (CDR (fetch OPARG of D))
((IDIFFERENCE IPLUS2)
(COND
((AND (NOT OPTIMIZATIONSOFF)
IPLUSNFLG
(EQ (CAR (fetch OPARG of D))
2)
(IGEQ A 0)
(ILEQ A 255))
(RPLACA LL (SELECTQ (CDR (fetch OPARG of D))
(IDIFFERENCE (QUOTE IDIFFERENCE.N))
(QUOTE IPLUS.N)))
(RPLACA (CDR LL)
A)
(SETQ LL (CDR LL))
(GO LP))))
(\CALLME (COND
((EQ (CAR (fetch OPARG of D))
1)
(SETQ FRAMENAME A)
(RPLNODE2 LL (CDDR LL))
(GO LP))))
NIL)))
(COND
((FASSOC A CONSTOPS) (* HAS OPCODE)
)
((AND (FIXP A)
(IGEQ A -256)
(ILEQ A 65535))
[SETQ LL (PROG1 (CDR LL)
(RPLACA LL (COND
((ILESSP A 0)
(push (CDR LL)
(IPLUS 256 A))
(QUOTE SNIC))
((IGREATERP A 255)
(push (CDR LL)
(LRSH A 8)
(LOGAND A 255))
(QUOTE SICX))
(T (push (CDR LL)
A)
(QUOTE SIC]
(GO LP))))
(BIND (PROG [(FRAME (CDR A))
(VARS (fetch (FRAME VARS) of (CDR A]
(DECLARE (SPECVARS FRAME)) (* frame is used free
below DASSEM.MATCHVARS)
[COND
((NEQ FRAME TOPFRAME)
(for VAR in VARS when (EQ (CAR VAR)
(QUOTE HVAR))
do (* eliminate name of
LOCALVAR variable)
(RPLACD VAR NIL]
(COND
[(NULL LOCALS) (* no local variables
seen yet. Assign var
numbers sequentially)
(DASSEM.COUNTVARS (SETQ LOCALS (APPEND VARS]
(T (* try to share binding
pointers with some
previously seen local
variables)
(DASSEM.MATCHVARS VARS LOCALS)))
(* remember this frame
as having been seen)
(push FRAMES (CDR A))))
(GVAR [SETQ LL (PROG1 (CDR LL)
(RPLNODE LL (COND
((EQ X (CAR LL))
(QUOTE GVAR))
(T (QUOTE GVAR←)))
(CONS 0 (CONS (CONS (QUOTE ATOM)
A)
(CDR LL]
(GO LP))
(FVAR [COND
[(SETQ D (FASSOC A FREELST)) (* count how often each
var occurs)
(FRPLACD (CDR D)
(ADD1 (CDDR D]
(T (SETQ FREELST (CONS (CONS A (CONS (CAR X)
0))
FREELST])
(SETQ [SETQ A (fetch OPARG of (SETQ X (fetch OPARG of X]
(GO PR))
NIL)
(SETQ LL (CDR LL))
(GO LP)
OUT (SETQ A 0)
[MAPC [SORT FREELST (FUNCTION (LAMBDA (X Y)
(IGREATERP (CDDR X)
(CDDR Y]
(FUNCTION (LAMBDA (X)
(replace FREEVARINDEX of (CAR X) with A)
(ADD1VAR A] (* Assign numbers to
the free variables
(most frequent first))
[MAPC FREELST (FUNCTION (LAMBDA (X)
(FRPLACD X (PROG1 (CAR X)
(FRPLACA X (CADR X]
(SETQ FREEVARS FREELST)))
(* * SCAN CODE)
(SETQ NLOCALS (IDIFFERENCE VARCOUNT NARGS))
(CHECKRANGE NARGS NARGMAX (QUOTE ARGS))
(CHECKRANGE NLOCALS NLOCALMAX (QUOTE LOCALS))
(SETQ NFREEVARS (LENGTH FREEVARS))
(CHECKRANGE NFREEVARS NFREEMAX (QUOTE FREEVARS))
(PROGN (* TURN INTO REAL CODE)
(PROG ((CODELOC 0)
(LL CODE)
OP X D A JL N)
LP (COND
((NULL LL)
(SETQ CD (OPT.DREV CD))
(OPT.RESOLVEJUMPS (OPT.DREV JL)
(QUOTE AJSIZES)
(FUNCTION DASSEM.ASMAJ))
(RETURN)))
(SETQ X (CAR LL))
(COND
((NLISTP X)
(AST X)
(GO NEXT)))
(SETQ A (fetch OPARG of X))
(SELECTQ (SETQ OP (fetch OPNAME of X))
((AVAR HVAR)
[SETQ OP (COND
((ILESSP (SETQ A (fetch VARINDEX of X))
NARGS)
(QUOTE (IVAR . IVARX)))
(T (SETQ A (IDIFFERENCE A NARGS))
(QUOTE (PVAR . PVARX]
[COND
((ILESSP A (OPCOUNT (CAR OP)))
(AST (LIST (CAR OP)
A)))
(T (AST (CDR OP))
(AST (LLSH A 1])
(FN [COND
((LISTP (SETQ D (CDR A)))
(OR (EQ (CAR D)
(QUOTE OPCODES))
(OPT.COMPILERERROR))
(for X in (CDR D) do (AST X)))
[(SETQ D (GETP D (QUOTE DOPVAL))) (* A fn has DOPVAL)
(PROG ((N (CAR A))
(F (CDR A)))
OPLP
(COND
((NLISTP D))
[(OR (EQ [CAR (SETQ A (COND
((FIXP (CAR D))
(PROG1 D (SETQ D)))
(T (CAR D]
N)
(NULL (CAR A)))
(COND
((LISTP (SETQ D (CDR A)))
(RETURN (MAPC D (FUNCTION (LAMBDA (X)
(AST X]
((ILESSP N (CAR A)) (* A fn with DOPVAL
supplied too few args)
(SETQ LL (CONS (create OP
OPNAME ←(QUOTE FN)
OPARG ←(CONS (CAR A)
F))
(CDR LL))) (* put out NIL's and
change # args.)
(FRPTQ (IDIFFERENCE (CAR A)
N)
(SETQ LL (CONS OPNIL LL)))
(GO LP))
((NULL (CDR D)) (* A fn with DOPVAL
supplied too many args)
(SETQ LL (CONS (create OP
OPNAME ←(QUOTE FN)
OPARG ←(CONS (CAR A)
F))
(CDR LL)))
(FRPTQ (IDIFFERENCE N (CAR A))
(SETQ LL (CONS OPPOP LL)))
(GO LP))
(T (SETQ D (CDR D))
(GO OPLP)))
APPLY
(SETQ LL (APPLY* D (fetch OPARG of X)
LL]
(T (SELECTQ (CAR A)
(0 (AST (QUOTE FN0))
(DASSEM.DSTOREFN (CDR A)))
(1 (AST (QUOTE FN1))
(DASSEM.DSTOREFN (CDR A)))
(2 (AST (QUOTE FN2))
(DASSEM.DSTOREFN (CDR A)))
(3 (AST (QUOTE FN3))
(DASSEM.DSTOREFN (CDR A)))
(4 (AST (QUOTE FN4))
(DASSEM.DSTOREFN (CDR A)))
(PROGN (AST (QUOTE FNX))
(AST (CAR A))
(DASSEM.DSTOREFN (CDR A])
((JUMP FJUMP TJUMP NTJUMP NFJUMP)
(push JL (create JD
JPT ←(push CD X)
JMIN ← CODELOC))
[add CODELOC (CAAR (GETP OP (QUOTE AJSIZES])
(TAG (replace (TAG JD) of X with (SETQ D (create JD
JMIN ← CODELOC)))
(SETQ JL (CONS D JL)))
(CONST [COND
((SETQ D (FASSOC A CONSTOPS))
(AST (CDR D)))
((LITATOM A)
(AST (QUOTE ACONST))
(AST 0)
(AST (CONS (QUOTE ATOM)
A)))
(T (AST (QUOTE GCONST))
(AST 0)
(AST 0)
(AST (CONS (QUOTE PTR)
A])
(SETQ (SELECTQ (fetch OPNAME of A)
((AVAR HVAR)
[COND
((ILESSP (SETQ D (fetch VARINDEX of A))
NARGS)
(AST (QUOTE IVARX←))
(AST (LLSH D 1)))
(T (SETQ D (IDIFFERENCE D NARGS))
(COND
([AND (EQ (fetch OPNAME of (CADR LL))
(QUOTE POP))
(ILESSP D (OPCOUNT (QUOTE PVAR←↑]
(SETQ LL (CDR LL))
(AST (LIST (QUOTE PVAR←↑)
D)))
((ILESSP D (OPCOUNT (QUOTE PVAR←)))
(AST (LIST (QUOTE PVAR←)
D)))
(T (AST (QUOTE PVARX←))
(AST (LLSH D 1])
(FVAR (AST (QUOTE FVARX←))
(AST (LLSH (IPLUS NLOCALS (fetch FREEVARINDEX
of (fetch OPARG of A)))
1)))
(OPT.COMPILERERROR)))
(FVAR [COND
((ILESSP (SETQ A (IPLUS NLOCALS (fetch FREEVARINDEX of A)))
(OPCOUNT (QUOTE FVAR)))
(AST (LIST (QUOTE FVAR)
A)))
(T (AST (QUOTE FVARX))
(AST (LLSH A 1])
(BIND (SETQ A (CDR A))
(DASSEM.DASMBIND (fetch NVALS of A)
(fetch NNILS of A)
(COND
((SETQ D (fetch VARS of A))
(IDIFFERENCE (fetch VARINDEX of (CAR D))
NARGS))
(T 1))))
((UNBIND DUNBIND)
(SETQ A (CDR A))
(COND
((IGREATERP (fetch NVALS of A)
15)
(OPT.COMPILERERROR))) (* if did extra BINDs
because of #NILs bound,
do extra UNBINDs)
(FRPTQ (ADD1 (LRSH (fetch NNILS of A)
4))
(AST OP)))
(ATOM (AST X))
(STORE (AST (QUOTE STORE.N))
(OR (GREATERP A 0)
(SHOULDNT))
(AST (LLSH (SUB1 A)
1)))
(*STORE [MAPC A (FUNCTION (LAMBDA (X)
(AST X])
(COPY (COND
(A (if (EQ A 0)
then (HELP))
(AST (QUOTE COPY.N))
(AST (LLSH A 1)))
(T (AST OP))))
(AST OP))
NEXT
(SETQ LL (CDR LL))
(GO LP)))
(DASSEM.DWRITEFN FN FRAMENAME ARGTYPE ARGS LOCALS FREEVARS CD])
(DASSEM.DWRITEFN
[LAMBDA (FN FRAMENAME ARGTYPE ARGS LOCALS FREEVARS CD) (* lmm
"24-Mar-85 14:40")
(RESETLST
(RESETSAVE (RADIX 8))
(PROG ((NARGS (LENGTH ARGS))
(NLOCALS (LENGTH LOCALS))
(NFREEVARS (LENGTH FREEVARS))
LOCALVARINFO) (* WRITE OUT DEFINITION)
(PROG ([LC (FLENGTH (NCONC1 CD (QUOTE -X-]
NAMETABLE)
[PROGN
(* Construct the name table. Is a flattened list of entries <code, index,
varname>, where code is one of P, I, F.
First come PVAR's, in reverse order of binding, then IVAR's, then FVAR's.
Thus free variable lookup can search the table in order.
We build NAMETABLE backwards, consing onto front)
[COND
(FREEVARS (for X in FREEVARS as I from NLOCALS
do (push NAMETABLE (CDR X)
I
(QUOTE F))) (* Fine, but backwards:
the FVARS need to be in
order, while the PVARS
want to be in reverse
order)
(SETQ NAMETABLE (DREVERSE NAMETABLE]
[for X in ARGS as I from 0 do (COND
((NEQ (CAR X)
(QUOTE HVAR))
(push NAMETABLE (QUOTE I)
I
(CDR X)))
(T (* Need to save
localvar args for
ARGLIST)
(push LOCALVARINFO I (CDR X]
[for X in LOCALS as I from 0 do (COND
((NEQ (CAR X)
(QUOTE HVAR))
(push NAMETABLE (QUOTE P)
I
(CDR X)))
((AND (EQ ARGTYPE 2)
(EQ I 0))
(push LOCALVARINFO I (CDR X]
(COND
((AND LOCALVARINFO (DASSEM.SAVELOCALVARS FN)) (* Keep this separate,
so for now DCODERD can
easily discard it)
(push NAMETABLE (QUOTE L)
LOCALVARINFO]
(COND
((NEQ FRAMENAME FN)
(push NAMETABLE (QUOTE NAME)
FRAMENAME)))
(SELECTQ LAPFLG
((2 T)
(DASSEM.DPRINTLAP FN NAMETABLE ARGTYPE CD))
NIL)
[COND
(LCFIL
(RESETSAVE (OUTPUT LCFIL))
(RESETSAVE (SETREADTABLE CODERDTBL))
(PROG [FNFIX ATOMFIX PTRFIX (COFD (GETOFD LCFIL (QUOTE OUTPUT]
(PRIN4 FN NIL FILERDTBL)
(PRIN3 " ")
(PRIN4 CODEINDICATOR NIL FILERDTBL)
(TERPRI)
(PRIN4 NAMETABLE)
(PRIN3 " ")
(\BOUT COFD (LRSH LC 8))
(\BOUT COFD (LOGAND LC 255))
(\BOUT COFD NLOCALS)
(\BOUT COFD NFREEVARS)
(\BOUT COFD ARGTYPE)
(\BOUT COFD NARGS)
[for X in CD as LOC from 0
do (\BOUT COFD (COND
[(NLISTP X)
(COND
((AND (FIXP X)
(IGEQ X 0)
(ILEQ X 255))
X)
(T (fetch OP# of (\FINDOP X T]
(T (SELECTQ (CAR X)
(FN (push FNFIX LOC (CDR X))
0)
(ATOM (push ATOMFIX LOC (CDR X))
0)
(PTR (push PTRFIX LOC (CDR X))
0)
(IPLUS (CAR (fetch OP#
of (\FINDOP (CAR X)
T)))
(CADR X]
(PRIN4 FNFIX)
(TERPRI)
(PRIN4 ATOMFIX)
(TERPRI)
(PRIN3 "(")
[for X in PTRFIX do (SPACES 1)
(COND
((EQ (CAR X)
LOADTIMECONSTANTMARKER)
(BOUT NIL (CHARCODE ↑Y))
(PRIN4 (CDR X)))
(T (PRIN4 X]
(PRIN3 ")")
(TERPRI]
(COND
(STRF (DASSEM.DSTOREFNDEF FN CD LC ARGTYPE NARGS NLOCALS NFREEVARS NAMETABLE)))
(RETURN FN])
(DASSEM.SAVELOCALVARS
[LAMBDA (FN)
T])
(DASSEM.DSTOREFNDEF
[LAMBDA (FN CD LC ARGTYPE NARGS NLOCALS NFREEVARS NAMETABLE) (* lmm
"24-Mar-85 14:21")
(PROG ((NTSIZE 0)
(FRAMENAME FN)
REALSIZE STARTPC NTWORDS CA FVAROFFSET LOCALARGS STARTLOCALS LOCALSIZE)
[COND
((EQ (CAR NAMETABLE)
(QUOTE NAME))
(SETQ FRAMENAME (CADR NAMETABLE))
(SETQ NAMETABLE (CDDR NAMETABLE]
[COND
((EQ (CAR NAMETABLE)
(QUOTE L))
(SETQ LOCALARGS (CADR NAMETABLE))
(SETQ NAMETABLE (CDDR NAMETABLE]
[COND
(NAMETABLE (* NAMETABLE now is a
sequence of flat
triples, one per name
to be stored in
nametable)
(on NAMETABLE by CDDDR do (add NTSIZE 1))
(SETQ NTSIZE (CEIL (ADD1 NTSIZE)
WORDSPERQUAD]
[SETQ NTWORDS (COND
(NAMETABLE (IPLUS NTSIZE NTSIZE))
(T (CONSTANT WORDSPERQUAD]
(* NameTable must end in quadword which ends in 0 -
thus, round down and add a quad -
NTWORDS is the number of words allocated for nametable)
(SETQ STARTPC (UNFOLD (IPLUS (fetch (CODEARRAY OVERHEADWORDS) of T)
NTWORDS)
BYTESPERWORD)) (* initial pc for the
function: after fixed
header and double
nametable)
[COND
(LOCALARGS (SETQ STARTLOCALS STARTPC) (* Insert an extra
nametable between the
real one and the start
pc where we store
localvar args)
(SETQ LOCALSIZE (CEIL (ADD1 (FOLDLO (FLENGTH LOCALARGS)
2))
(IQUOTIENT WORDSPERQUAD 2))) (* Number of words in
half this nametable:
must end in zero, when
doubled is quad-aligned)
(SETQ LOCALSIZE (UNFOLD LOCALSIZE BYTESPERWORD)) (* size in bytes now)
(add STARTPC (UNFOLD LOCALSIZE 2]
(SETQ REALSIZE (CEIL (IPLUS STARTPC LC)
BYTESPERQUAD))
(SETQ CA (\CODEARRAY REALSIZE (CEIL (ADD1 (FOLDHI STARTPC BYTESPERCELL))
CELLSPERQUAD)))
[for X in CD as LOC from STARTPC
do (COND
[(NLISTP X)
(CODESETA CA LOC (COND
((AND (FIXP X)
(IGEQ X 0)
(ILEQ X 255))
X)
(T (* assume that this is
an opcode which isn't a
"range")
(fetch OP# of (\FINDOP X T]
(T (SELECTQ (CAR X)
(FN (\FIXCODENUM CA LOC (\ATOMDEFINDEX (CDR X))))
(ATOM (\FIXCODENUM CA LOC (\ATOMPNAMEINDEX (CDR X))))
(PTR (\FIXCODEPTR CA LOC (if (EQ (CADR X)
LOADTIMECONSTANTMARKER)
then (EVAL (CDDR X))
else (CDR X))))
(PROGN (* assume that this is
a "range" type opcode)
(CODESETA CA LOC (IPLUS (CAR (fetch OP# of (\FINDOP (CAR X)
T)))
(CADR X] (* Now build the name
table, which has two
parallel parts: the
names, and where to
find them on the stack)
(for X on NAMETABLE by (CDDDR X) as NT1 from (ADD1 (UNFOLD (fetch (CODEARRAY OVERHEADWORDS)
of T)
BYTESPERWORD))
by (CONSTANT BYTESPERWORD) bind (NTBYTESIZE ←(UNFOLD NTSIZE BYTESPERWORD))
do (\FIXCODENUM CA NT1 (\ATOMVALINDEX (CADDR X))
-1) (* Insert the name into
first half of table)
(\FIXCODENUM CA (IPLUS NT1 NTBYTESIZE)
(IPLUS (CADR X)
(SELECTQ (CAR X)
(P (CONSTANT PVARCODE))
(F (OR FVAROFFSET (SETQ FVAROFFSET (FOLDLO NT1 BYTESPERWORD)))
(* Save word offset of
first FVAR in
nametable, so ucode can
easily access FVAR n)
(CONSTANT FVARCODE))
(I (CONSTANT IVARCODE))
(SHOULDNT)))
-1) (* Code type and index
into second half))
[COND
(LOCALARGS (* Build invisible name
table for locals)
(for X on LOCALARGS by (CDDR X) as NT from (ADD1 STARTLOCALS) by BYTESPERWORD
do (\FIXCODENUM CA NT (\ATOMVALINDEX (CADR X))
-1) (* Name in first half)
(\FIXCODENUM CA (IPLUS NT LOCALSIZE)
(IPLUS (CAR X)
(CONSTANT IVARCODE))
-1) (* index in second half)]
(PROGN (* Fill in function
header)
(replace (CODEARRAY NA) of CA with (COND
((EQ ARGTYPE 2)
-1)
(T NARGS)))
(replace (CODEARRAY PV) of CA with (SUB1 (FOLDHI (IPLUS NLOCALS NFREEVARS)
CELLSPERQUAD)))
(replace (CODEARRAY STARTPC) of CA with STARTPC)
(replace (CODEARRAY ARGTYPE) of CA with ARGTYPE)
(replace (CODEARRAY FRAMENAME) of CA with FRAMENAME)
(replace (CODEARRAY NTSIZE) of CA with NTSIZE)
(replace (CODEARRAY NLOCALS) of CA with NLOCALS)
(replace (CODEARRAY FVAROFFSET) of CA with (OR FVAROFFSET 0))
(replace (CODEARRAY FIXED) of CA with T))
(RESETVARS ((DFNFLG (if SVFLG
then NIL
else T)))
(DPUTCODE FN CA (IPLUS STARTPC LC])
(DASSEM.DPRINTLAP
[LAMBDA (FN NAMETABLE ARGTYPE CD) (* lmm
"22-DEC-81 00:17")
(RESETLST (RESETSAVE (OUTPUT LSTFIL))
(RESETSAVE (RADIX 8))
(printout NIL .P2 FN T "name table: " T .P2 NAMETABLE T "code length: " " argtype: "
ARGTYPE T)
(MAPRINT CD NIL NIL NIL NIL (FUNCTION PRIN2))
(printout NIL T T])
(DASSEM.EQCONSTANTP
[LAMBDA (ARG FLG) (* lmm
"26-DEC-81 15:52")
(OR (LITATOM ARG)
(AND (FIXP ARG)
(IGEQ ARG -65536)
(ILEQ ARG 65535])
(DASSEM.MATCHVARS
[LAMBDA (VARS TAIL) (* lmm
"29-JUL-81 07:03")
(* find a match for
VARS in TAIL (a tail of
LOCALS) -
tack VARS onto end if
not possible)
(COND
[(AND (for VAR in VARS as X in TAIL always (EQUAL VAR X))
(for VAR in VARS as X in TAIL always (DASSEM.CANSHAREBINDING VAR X)))
(* variables in VARS
can share binding
pointers with variables
in TAIL)
(PROG NIL
LP (replace VARINDEX of (CAR VARS) with (fetch VARINDEX of (CAR TAIL)))
(COND
((SETQ VARS (CDR VARS))
(COND
((CDR TAIL)
(SETQ TAIL (CDR TAIL))
(GO LP))
(T (* some variables left;
tack onto end)
(DASSEM.COUNTVARS VARS)
(RPLACD TAIL VARS]
((CDR TAIL)
(DASSEM.MATCHVARS VARS (CDR TAIL)))
(T (DASSEM.COUNTVARS VARS)
(RPLACD TAIL VARS])
(DASSEM.COUNTVARS
[LAMBDA (VARS) (* lmm
"26-JAN-80 21:23")
(* assign sequential
variable numbers to
VARS)
(for VAR in VARS do (replace VARINDEX of VAR with (PROG1 VARCOUNT (ADD1VAR VARCOUNT])
(DASSEM.CANSHAREBINDING
[LAMBDA (V1 V2) (* lmm
"22-DEC-81 22:58")
(* can the two variables V1 and V2 share binding pointers? -
yes, if they are both either (HVAR) or else both
(AVAR . atom) with same atom name, and V2's frame
(and the frame of any variable which shares a binding pointer with V2) is
mutually exclusive from V1's frame (i.e., both binds cannot happen at the
same time))
(AND (EQUAL V1 V2)
(for FR in FRAMES when (AND (find V3 in (fetch (FRAME VARS) of FR)
suchthat (EQ (fetch VARINDEX of V3)
(fetch VARINDEX of V2)))
(OR (PARENTP FR FRAME)
(PARENTP FRAME FR))) do (* KILROY wuz here)
(RETURN NIL)
finally (RETURN T])
)
(DECLARE: EVAL@COMPILE
(DEFCONSTANT NARGMAX 127)
(DEFCONSTANT NLOCALMAX 127)
(DEFCONSTANT NFREEMAX 127)
(CONSTANTS NARGMAX NLOCALMAX NFREEMAX)
)
(DEFINEQ
(DASSEM.DASMBIND
[LAMBDA (NV NN K) (* lmm
"13-Jul-84 21:18")
(COND
[(IGREATERP NV 15)
(COMPERROR (CONS NV (QUOTE (- too many values bound]
((IGREATERP NN 15) (* BIND of more than 15
NIL s)
(DASSEM.DASMBIND NV 15 K)
(DASSEM.DASMBIND 0 (IDIFFERENCE NN 15)
(IPLUS K NV 15)))
(T (* BIND opcode)
(AST (QUOTE BIND))
(AST (IPLUS (LLSH NN 4)
NV))
(AST (SUB1 (IPLUS K NV NN])
(DASSEM.DSTOREFN
[LAMBDA (X) (* lmm
" 7-JUL-80 22:02")
(* edited (7-NOV-74 . 2243))
(AST 0)
(AST (CONS (QUOTE FN)
X])
(DASSEM.ASMAJ
[LAMBDA (P D) (* lmm
" 8-Nov-84 18:46")
(PROG ((OP (CAAR P))
Y S)
(SETQ Y (GETP OP (QUOTE MOPVAL)))
(SELECTQ (SETQ S (OPT.JSIZE (CAR P)
D
(QUOTE AJSIZES)))
(1 (* 1 byte jump -
JUMP FJUMP TJUMP)
[FRPLACA P (if (ILESSP D 2)
then (OR (AND (EQ D 1)
(SELECTQ (CAAR P)
(JUMP (QUOTE NOP))
((TJUMP FJUMP)
(QUOTE POP))
NIL))
(COMPILER.ERROR))
else (LIST (CAR Y)
(IPLUS D -2])
(2 (* 2 byte jump --
JUMPX TJUMPX FJUMPX
NTJUMPX NFJUMPX)
(FRPLNODE P (CADR Y)
(CONS (COND
((ILESSP D 0)
(COND
((ILESSP D -128)
(OPT.COMPILERERROR)))
(IPLUS 256 D))
(T (COND
((IGREATERP D 127)
(OPT.COMPILERERROR)))
D))
(CDR P))))
((3 4)
(* 3 byte jump is
JUMPXX. 4 byte jump is
FJUMP.+4 JUMPXX to
implement TJUMPXX)
[COND
((EQ S 3)
(OR (EQ (CADDR Y)
(QUOTE JUMPXX))
(OPT.COMPILERERROR))
(FRPLACA P (CADDR Y)))
(T (* long t/f jump
implemented by short
jump followed by JUMPXX)
(add D -1)
(FRPLNODE P (CADDR Y)
(SETQ P (CONS (QUOTE JUMPXX)
(CDR P]
[FRPLACD P (CONS (LOGAND (RSH D 8)
255)
(CONS (LOGAND D 255)
(CDR P])
(6 (* long NXJUMP
implemented by
NXJUMP.+2 JUMP.+4
JUMPXX.place IN 6 BYTES)
[FRPLNODE P (CADR Y)
(CONS 3 (CONS (QUOTE (JUMP 2))
(CONS (QUOTE JUMPXX)
(CONS (LRSH (SETQ D (LOGAND (IPLUS D -3)
65535))
8)
(CONS (LOGAND D 255)
(CDR P])
(OPT.COMPILERERROR])
)
(RPAQQ EMFLAG NIL)
(RPAQQ COMPILEMODE D)
(PUTPROPS JUMP MOPVAL (JUMP JUMPX JUMPXX))
(PUTPROPS FJUMP MOPVAL (FJUMP FJUMPX (TJUMP 2)))
(PUTPROPS TJUMP MOPVAL (TJUMP TJUMPX (FJUMP 2)))
(PUTPROPS NTJUMP MOPVAL (NIL NTJUMPX))
(PUTPROPS NFJUMP MOPVAL (NIL NFJUMPX))
(PUTPROPS JUMP AJSIZES ((1 . 3)
18
(1 (-127 3 . 2) . 1)
127 2 . 3))
(PUTPROPS FJUMP AJSIZES ((1 . 4)
18
(1 (-127 4 . 2) . 1)
127 2 . 4))
(PUTPROPS TJUMP AJSIZES ((1 . 4)
18
(1 (-127 4 . 2) . 1)
127 2 . 4))
(PUTPROPS NTJUMP AJSIZES ((2 . 6)
18
(2 (-127 6 . 2) . 2)
127 2 . 6))
(PUTPROPS NFJUMP AJSIZES ((2 . 6)
18
(2 (-127 6 . 2) . 2)
127 2 . 6))
(RPAQQ DOPVALS
(.APPLYFN. ARRAYP \BLT BitBltSUBR CAR CDR CONS CREATECELL DIFFERENCE DOCOLLECT ELT ENDCOLLECT
EQ FDIFFERENCE FGREATERP FLESSP FIX FIXP FLOATP FMEMB FPLUS FQUOTIENT FTIMES GETHASH
GETP GREATERP IDIFFERENCE IGREATERP ILESSP IPLUS IQUOTIENT IREMAINDER ITIMES LESSP
LISTP LLSH1 LLSH8 LOGAND LOGOR LOGXOR LRSH1 LRSH8 NTHCHC NTYPX NULL NUMBERP PLUS
QUOTIENT READPRINTERPORT RPLACA RPLACD RPLCHARCODE SETA SMALLP STACKP STRINGP TIMES
WRITEPRINTERPORT \ADDBASE \ARG0 BIN \BIN BOUT \BOUT \BOXIDIFFERENCE \BOXIPLUS
\CONTEXTSWITCH \EVAL \EVALV1 \GCRECLAIMCELL \GCSCAN1 \GCSCAN2 \MAKENUMBER \MTIMES3
\MTIMES4 \MYARGCOUNT \PILOTBITBLT \RCLK \READFLAGS \READRP \RPLCONS \STKSCAN \WRITEMAP
\\ADDBASE \FLOAT.BOX FLOAT \FLOATBOX \FLOATUNBOX \BLKEXPONENT \BLKMAG \BLKSMALLP2FLOAT
\BLKFLOATP2COMP \BLKPERM \BLKFTIMES \BLKFDIFF \BLKFPLUS \BLKSEP \IBLT1 \IBLT2 EQUAL
\DRAWLINE.UFN ASSOC LISTGET LSH \PIXELBLT EQL \MYALINK))
(PUTPROPS .APPLYFN. DOPVAL ((NIL APPLYFN)))
(PUTPROPS ARRAYP DOPVAL (1 TYPEP 6))
(PUTPROPS \BLT DOPVAL (3 BLT))
(PUTPROPS BitBltSUBR DOPVAL (1 '0 BITBLT))
(PUTPROPS CAR DOPVAL (1 CAR))
(PUTPROPS CDR DOPVAL (1 CDR))
(PUTPROPS CONS DOPVAL (2 CONS))
(PUTPROPS CREATECELL DOPVAL (1 CREATECELL))
(PUTPROPS DIFFERENCE DOPVAL (2 DIFFERENCE))
(PUTPROPS DOCOLLECT DOPVAL (2 DOCOLLECT))
(PUTPROPS ELT DOPVAL (2 ELT))
(PUTPROPS ENDCOLLECT DOPVAL (2 ENDCOLLECT))
(PUTPROPS EQ DOPVAL (2 EQ))
(PUTPROPS FDIFFERENCE DOPVAL (2 FDIFFERENCE))
(PUTPROPS FGREATERP DOPVAL (2 FGREATERP))
(PUTPROPS FLESSP DOPVAL (2 SWAP FGREATERP))
(PUTPROPS FIX DOPVAL (1 '0 IPLUS2))
(PUTPROPS FIXP DOPVAL (1 TYPEMASK.N 32))
(PUTPROPS FLOATP DOPVAL (1 TYPEP 3))
(PUTPROPS FMEMB DOPVAL (2 FMEMB))
(PUTPROPS FPLUS DOPVAL ((2 FPLUS2)))
(PUTPROPS FQUOTIENT DOPVAL (2 FQUOTIENT))
(PUTPROPS FTIMES DOPVAL ((2 FTIMES2)))
(PUTPROPS GETHASH DOPVAL (2 GETHASH))
(PUTPROPS GETP DOPVAL (2 GETP))
(PUTPROPS GREATERP DOPVAL (2 GREATERP))
(PUTPROPS IDIFFERENCE DOPVAL (2 IDIFFERENCE))
(PUTPROPS IGREATERP DOPVAL (2 IGREATERP))
(PUTPROPS ILESSP DOPVAL (2 SWAP IGREATERP))
(PUTPROPS IPLUS DOPVAL ((0 . OPT.COMPILERERROR)
(1 '0 IPLUS2)
(2 IPLUS2) . OPT.COMPILERERROR))
(PUTPROPS IQUOTIENT DOPVAL (2 IQUOTIENT))
(PUTPROPS IREMAINDER DOPVAL (2 IREMAINDER))
(PUTPROPS ITIMES DOPVAL ((0 . OPT.COMPILERERROR)
(1 0 IPLUS2)
(2 ITIMES2) . OPT.COMPILERERROR))
(PUTPROPS LESSP DOPVAL (2 SWAP GREATERP))
(PUTPROPS LISTP DOPVAL (1 LISTP))
(PUTPROPS LLSH1 DOPVAL (1 LLSH1))
(PUTPROPS LLSH8 DOPVAL (1 LLSH8))
(PUTPROPS LOGAND DOPVAL ((2 LOGAND2)))
(PUTPROPS LOGOR DOPVAL ((2 LOGOR2)))
(PUTPROPS LOGXOR DOPVAL ((2 LOGXOR2)))
(PUTPROPS LRSH1 DOPVAL (1 LRSH1))
(PUTPROPS LRSH8 DOPVAL (1 LRSH8))
(PUTPROPS NTHCHC DOPVAL (2 NTHCHC))
(PUTPROPS NTYPX DOPVAL (1 NTYPX))
(PUTPROPS NULL DOPVAL (1 'NIL EQ))
(PUTPROPS NUMBERP DOPVAL (1 TYPEMASK.N 16))
(PUTPROPS PLUS DOPVAL ((1 '0 PLUS2)
(2 PLUS2) . OPT.COMPILERERROR))
(PUTPROPS QUOTIENT DOPVAL (2 QUOTIENT))
(PUTPROPS READPRINTERPORT DOPVAL (0 READPRINTERPORT))
(PUTPROPS RPLACA DOPVAL (2 RPLACA))
(PUTPROPS RPLACD DOPVAL (2 RPLACD))
(PUTPROPS RPLCHARCODE DOPVAL (3 RPLCHARCODE))
(PUTPROPS SETA DOPVAL (3 SETA))
(PUTPROPS SMALLP DOPVAL (1 TYPEP 1))
(PUTPROPS STACKP DOPVAL (1 TYPEP 8))
(PUTPROPS STRINGP DOPVAL (1 TYPEP 7))
(PUTPROPS TIMES DOPVAL ((2 TIMES2)))
(PUTPROPS WRITEPRINTERPORT DOPVAL (1 WRITEPRINTERPORT))
(PUTPROPS \ADDBASE DOPVAL (2 ADDBASE))
(PUTPROPS \ARG0 DOPVAL (1 ARG0))
(PUTPROPS BIN DOPVAL (1 BIN))
(PUTPROPS \BIN DOPVAL (1 BIN))
(PUTPROPS BOUT DOPVAL (2 BOUT))
(PUTPROPS \BOUT DOPVAL (2 BOUT))
(PUTPROPS \BOXIDIFFERENCE DOPVAL (2 BOXIDIFFERENCE))
(PUTPROPS \BOXIPLUS DOPVAL (2 BOXIPLUS))
(PUTPROPS \CONTEXTSWITCH DOPVAL (1 CONTEXTSWITCH))
(PUTPROPS \EVAL DOPVAL (1 EVAL))
(PUTPROPS \EVALV1 DOPVAL (1 EVALV))
(PUTPROPS \GCRECLAIMCELL DOPVAL (1 RECLAIMCELL))
(PUTPROPS \GCSCAN1 DOPVAL (1 GCSCAN1))
(PUTPROPS \GCSCAN2 DOPVAL (1 GCSCAN2))
(PUTPROPS \MAKENUMBER DOPVAL (2 MAKENUMBER))
(PUTPROPS \MTIMES3 DOPVAL (3 UBFLOAT3 1))
(PUTPROPS \MTIMES4 DOPVAL (3 UBFLOAT3 2))
(PUTPROPS \MYARGCOUNT DOPVAL (0 MYARGCOUNT))
(PUTPROPS \PILOTBITBLT DOPVAL (2 PILOTBITBLT))
(PUTPROPS \RCLK DOPVAL (1 RCLK))
(PUTPROPS \READFLAGS DOPVAL (1 READFLAGS))
(PUTPROPS \READRP DOPVAL (1 READRP))
(PUTPROPS \RPLCONS DOPVAL (2 RPLCONS))
(PUTPROPS \STKSCAN DOPVAL (1 STKSCAN))
(PUTPROPS \WRITEMAP DOPVAL (3 WRITEMAP))
(PUTPROPS \\ADDBASE DOPVAL (2 ADDBASE))
(PUTPROPS \FLOAT.BOX DOPVAL (1 GCONST 0 0 (PTR . 0.0)
FPLUS2))
(PUTPROPS FLOAT DOPVAL ((1 DTEST 0 (ATOM . FLOATP))))
(PUTPROPS \FLOATBOX DOPVAL (1 UBFLOAT1 0))
(PUTPROPS \FLOATUNBOX DOPVAL (1 UBFLOAT1 1))
(PUTPROPS \BLKEXPONENT DOPVAL (3 MISC3 0))
(PUTPROPS \BLKMAG DOPVAL (3 MISC3 1))
(PUTPROPS \BLKSMALLP2FLOAT DOPVAL (3 MISC3 2))
(PUTPROPS \BLKFLOATP2COMP DOPVAL (3 MISC3 3))
(PUTPROPS \BLKPERM DOPVAL (4 MISC4 1))
(PUTPROPS \BLKFTIMES DOPVAL (4 MISC4 0))
(PUTPROPS \BLKFDIFF DOPVAL (4 MISC4 3))
(PUTPROPS \BLKFPLUS DOPVAL (4 MISC4 2))
(PUTPROPS \BLKSEP DOPVAL (4 MISC4 4))
(PUTPROPS \IBLT1 DOPVAL (8 MISC8 0))
(PUTPROPS \IBLT2 DOPVAL (8 MISC8 1))
(PUTPROPS EQUAL DOPVAL (2 EQUAL))
(PUTPROPS \DRAWLINE.UFN DOPVAL (9 DRAWLINE))
(PUTPROPS ASSOC DOPVAL (2 ASSOC))
(PUTPROPS LISTGET DOPVAL (2 LISTGET))
(PUTPROPS LSH DOPVAL (2 LSH))
(PUTPROPS \PIXELBLT DOPVAL (10 MISC10 0))
(PUTPROPS EQL DOPVAL (2 EQL))
(PUTPROPS \MYALINK DOPVAL (1 MYALINK))
(RPAQQ CONSTOPS ((NIL . 'NIL)
(T . 'T)
(0 . '0)
(1 . '1)))
(RPAQQ COMPILE.ARG.FAST.FLG NIL)
(RPAQQ IPLUSNFLG NIL)
(ADDTOVAR 8BITEXTS DCOM)
(ADDTOVAR MACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO)
(ADDTOVAR COMPILERMACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO)
(RPAQQ BYTEASSEMFN DASSEM.DASSEM)
(RPAQQ MAXBVALS 15)
(RPAQQ COMPILE.EXT DCOM)
(RPAQQ BYTECOMPFLG T)
(RPAQQ SELECTQFMEMB NIL)
(RPAQQ LAMBDANOBIND T)
(RPAQQ SELECTVARTYPES (AVAR HVAR))
(RPAQQ CONST.FNS [(NIL (1 CAR (CONST))
(1 CDR (CONST))
(1 NULL (CONST . T))
(2 EQ (FN 1 . NULL)))
(0 (2 ITIMES2 (POP)
(CONST . 0))
(2 LOGAND2 (POP)
(CONST . 0))
(2 IPLUS (FN 1 . FIX))
(2 LOGOR2 (FN 1 . FIX))
(2 \ADDBASE))
(1 (2 ITIMES2 (FN 1 . FIX])
(RPAQQ MERGEFRAMEFLG T)
(RPAQQ MERGEFRAMEMAX 2)
(RPAQQ CLEANFNLIST
(NTYPX EQ AND OR CONS LIST FMEMB MEMB GETP SUB1 ADD1 ZEROP ELT ILESSP LLSH LRSH IPLUS
IDIFFERENCE \ARG0 \CALLME GETHASH \ADDBASE))
(RPAQQ OPCODEPROP DOPVAL)
(RPAQQ VCONDITIONALS (ARRAYP FIXP FLOATP LISTP SMALLP STACKP NUMBERP))
(RPAQQ CONDITIONALS (EQ IGREATERP NULL GREATERP LESSP ILESSP))
(RPAQQ CONSTFNS (IPLUS SUB1 ADD1 ZEROP LLSH LRSH IDIFFERENCE))
(RPAQQ MAXARGS 80)
(RPAQQ XVARFLG NIL)
(RPAQQ NOFREEVARFNS (RPLACA RPLACD PUTHASH SETA))
(RPAQQ CLEANFNTEST DASSEM.CLEANFNTEST)
(RPAQQ EQCONSTFN DASSEM.EQCONSTANTP)
(ADDTOVAR NUMBERFNS LLSH1 LRSH1 LLSH8 LRSH8)
(DECLARE: EVAL@COMPILE
(RPAQQ SHALLOWFLG NIL)
(RPAQQ SPAGHETTIFLG T)
(CONSTANTS (SHALLOWFLG NIL)
(SPAGHETTIFLG T))
)
(DEFINEQ
(DASSEM.CLEANFNTEST
[LAMBDA (FN TYPE) (* lmm "23-May-86 16:27")
(DECLARE (GLOBALVARS CONDITIONALS VCONDITIONALS NUMBERFNS CLEANFNLIST NOFREEVARFNS NOSIDEFNS))
(COND
((LITATOM FN)
(OR (GETPROP FN (QUOTE CROPS))
(FMEMB FN CONDITIONALS)
(FMEMB FN VCONDITIONALS)
(FMEMB FN NUMBERFNS)
(FMEMB FN CLEANFNLIST)
(SELECTQ TYPE
(FREEVARS (FMEMB FN NOFREEVARFNS))
(NOSIDE (FMEMB FN NOSIDEFNS))
NIL)))
((EQ (CAR FN)
(QUOTE OPCODES))
(while (SETQ FN (CDR FN))
do
[SELECTQ (CAR FN)
((GETBASEPTR.N GETBASE.N)
(SETQ FN (CDR FN)))
(GETBITS.N.FD (SETQ FN (CDDR FN)))
(ARG0)
(GCONST (SETQ FN (CDDDR FN)))
(COND
((LISTP (CAR FN))
(SELECTQ (CAAR FN)
(IVAR)
(RETURN)))
(T (RETURN]
finally
(RETURN T])
)
(PUTPROPS ATOM DMACRO (OPENLAMBDA (X)
(OR (NULL X)
(AND (\TYPEMASK.UFN X 8)
T))))
(PUTPROPS EVALV DMACRO [X (COND ((CADR X)
(QUOTE IGNOREMACRO))
(T (CONS (QUOTE \EVALV1)
X])
(PUTPROPS FGETD DMACRO COMP.GETD)
(PUTPROPS FGREATERP DMACRO (APPLY* COMP.COMPARENUM FLOAT FGREATERP NIL (OPCODES UBFLOAT2 5)))
(PUTPROPS FLESSP DMACRO (APPLY* COMP.COMPARENUM FLOAT FLESSP FGREATERP (OPCODES SWAP UBFLOAT2 5)))
(PUTPROPS FMEMB DMACRO COMP.FMEMB)
(PUTPROPS FRPLACA DMACRO (= . RPLACA))
(PUTPROPS FRPLACD DMACRO COMP.RPLACD)
(PUTPROPS GETATOMVAL DMACRO ((ATM)
(GETTOPVAL ATM)))
(PUTPROPS GETD DMACRO COMP.GETD)
(PUTPROPS GREATERP DMACRO (APPLY* COMP.COMPARENUM PLUS GREATERP))
(PUTPROPS IGREATERP DMACRO (APPLY* COMP.COMPARENUM FIX IGREATERP))
(PUTPROPS ILESSP DMACRO (APPLY* COMP.COMPARENUM FIX ILESSP IGREATERP))
(PUTPROPS LESSP DMACRO (APPLY* COMP.COMPARENUM PLUS LESSP GREATERP))
(PUTPROPS LIST DMACRO [X (AND X (LIST (QUOTE CONS)
(CAR X)
(CONS (QUOTE LIST)
(CDR X])
(PUTPROPS LITATOM DMACRO ((X)
(EQ (NTYPX X)
4)))
(PUTPROPS LLSH DMACRO COMP.SHIFT)
(PUTPROPS LRSH DMACRO COMP.SHIFT)
(PUTPROPS MINUSP DMACRO ((X)
(GREATERP 0 X)))
(PUTPROPS NTHCHARCODE DMACRO [X (COND ((NULL (CADDR X))
(LIST (QUOTE NTHCHC)
(CAR X)
(CADR X)))
(T (QUOTE IGNOREMACRO])
(PUTPROPS PRINTNUM DMACRO T)
(PUTPROPS RESETSAVE DMACRO [X (LIST (QUOTE SETQ)
(QUOTE RESETVARSLST)
(LIST (QUOTE CONS)
[COND [(AND (ATOM (CAR X))
(CAR X))
(SUBPAIR (QUOTE (VAR VAL))
X
(QUOTE (PROG1 (CONS (QUOTE VAR)
(GETTOPVAL (QUOTE VAR)))
(SETTOPVAL (QUOTE VAR)
VAL]
((CDR X)
(LIST (QUOTE LIST)
(CADR X)
(CAR X)))
(T (LIST (QUOTE LIST)
(LIST (QUOTE LIST)
[LIST (QUOTE QUOTE)
(COND ((EQ (CAAR X)
(QUOTE SETQ))
(CAR (CADDAR X)))
(T (CAAR X]
(CAR X]
(QUOTE RESETVARSLST])
(PUTPROPS RESETVAR DMACRO ((VAR VAL FORM)
(PROG (MACROX MACROY)
(SETQ MACROX (SETQ RESETVARSLST (CONS (CONS (QUOTE VAR)
(GETTOPVAL (QUOTE VAR)))
RESETVARSLST)))
(SETQ MACROY (XNLSETQ (PROGN (SETTOPVAL (QUOTE VAR)
VAL)
FORM)
INTERNAL))
(SETTOPVAL (QUOTE VAR)
(CDAR MACROX))
(SETQ RESETVARSLST (CDR MACROX))
[COND (MACROY (RETURN (CAR MACROY]
(ERROR!))))
(PUTPROPS RESETVARS DMACRO
[TAIL
(PROG
[(VARS (MAPCAR (CAR TAIL)
(FUNCTION (LAMBDA (Z)
(SETQ Z (MKLIST Z))
[AND EMFLAG (NOT (COMP.GLOBALVARP (CAR Z)))
(COMPERRM (CONS (CAR Z)
(QUOTE (- not GLOBALVAR in RESETVARS]
Z]
(RETURN
(BQUOTE
(PROG
([MACROX (SETQ RESETVARSLST %,
(PROG ((Z (QUOTE RESETVARSLST)))
[MAPC (REVERSE VARS)
(FUNCTION (LAMBDA
(V)
(SETQ Z (BQUOTE
(CONS (CONS (QUOTE %, (CAR V))
%,
(CAR V))
%, Z]
(RETURN Z]
MACROY)
(SETQ MACROY RESETVARSLST)
(RETURN
(CAR (OR [PROG1 (XNLSETQ (PROG NIL [PROGN %,. (MAPCAR VARS (FUNCTION
(LAMBDA
(V)
(CONS (QUOTE SETQ)
V]
%,.
(CDR TAIL))
INTERNAL)
%,.
(MAPCON VARS
(FUNCTION (LAMBDA
(V)
(BQUOTE ((SETQ %, (CAAR V)
(CDAR MACROX))
%,
(COND
[(CDR V)
(QUOTE (SETQ MACROX (CDR MACROX]
(T (QUOTE (COND ((EQ MACROY RESETVARSLST)
(SETQ RESETVARSLST
(CDR MACROX)))
((TAILP MACROY
RESETVARSLST)
(RPLACD (NLEFT
RESETVARSLST
1 MACROY)
(CDR MACROX]
(ERROR!])
(PUTPROPS RPLACD DMACRO COMP.RPLACD)
(PUTPROPS SETATOMVAL DMACRO ((ATM VAL)
(SETTOPVAL ATM VAL)))
(PUTPROPS SYSTEMTYPE DMACRO (NIL (QUOTE D)))
(PUTPROPS \FLOATBOX DMACRO C.FLOATBOX)
(PUTPROPS \FLOATUNBOX DMACRO C.FLOATUNBOX)
(PUTPROPS IEQP DMACRO ((X Y)
(EQ 0 (IDIFFERENCE X Y))))
(PUTPROPS FASSOC DMACRO (= . ASSOC))
(DEFINEQ
(COMP.RPLACD
[LAMBDA (A) (* lmm
"13-Jul-84 21:18")
(PROG NIL
(COMP.EXPR (CAR A))
[COND
((OPT.CALLP (CAR CODE)
(QUOTE CONS)) (* (RPLACD (CONS --) --)
-> (CONS & &))
(FRPTQ (PROG1 (CAR (fetch OPARG of (CAR CODE)))
(COMP.DELFN)
(COMP.STCONST))
(SELECTQ (fetch OPNAME of (CAR CODE))
((CONST AVAR FVAR HVAR GVAR)
(COMP.DELPUSH))
(COMP.STPOP)))
(COMP.VAL1 (CDR A))
(RETURN (COMP.STFN (QUOTE CONS)
(COND
((EQ (CAR CODE)
OPNIL)
(COMP.DELPUSH)
1)
(T 2]
DOIT
(OR (EQ COMPILE.CONTEXT (QUOTE EFFECT))
(COMP.STCOPY))
(COMP.VAL1 (CDR A))
(COND
((AND (EQ (fetch OPNAME of (CAR CODE))
(QUOTE SETQ))
(OPT.CALLP (CADR CODE)
(QUOTE CONS)
1))
(COMP.ST (PROG1 (pop CODE)
(COMP.DELFN)
(COMP.STFN (QUOTE \RPLCONS)
2))
0))
((OPT.CALLP (CAR CODE)
(QUOTE CONS)
1)
(COMP.DELFN)
(COMP.STFN (QUOTE \RPLCONS)
2))
(T (COMP.STFN (QUOTE RPLACD)
2)))
(COMP.STPOP)
(RETURN (QUOTE NOVALUE])
(COMP.SHIFT
[LAMBDA (A) (* JonL
" 3-Dec-84 21:15")
(COMP.VAL (CAR A))
(COMP.DELFIX)
(COMP.VAL (CADR A))
(COMP.DELFIX)
(COND
[(EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST)) (* A compile shift open)
(PROG ((N (fetch OPARG of (CAR CODE)))
FNS)
[OR (FIXP N)
(COMPERROR (CONS N (QUOTE (non-numeric arg to shift]
(COMP.DELPUSH)
[COND
((EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(RETURN (COMP.STCONST (PROG1 (APPLY* (CAR EXP)
(fetch OPARG of (CAR CODE))
N)
(COMP.DELPUSH]
[SETQ FNS (SELECTQ [COND
((EQ 0 N)
(RETURN))
((IGREATERP N 0)
(CAR EXP))
(T (SETQ N (IMINUS N))
(SELECTQ (CAR EXP)
(LLSH (QUOTE LRSH))
(QUOTE LLSH]
(LLSH (QUOTE (LLSH8 . LLSH1)))
(QUOTE (LRSH8 . LRSH1]
LP8 (COND
((IGREATERP N 7)
(COMP.STFN (CAR FNS)
1)
(SETQ N (IDIFFERENCE N 8))
(GO LP8)))
LP1 (COND
((IGREATERP N 0)
(COMP.STFN (CDR FNS)
1)
(SETQ N (SUB1 N))
(GO LP1]
(T (* A can't compile shift
open)
(COMP.STFN (CAR EXP)
2])
(COMP.COMPARENUM
[LAMBDA (A TYPE FN OFN) (* lmm
"24-Jan-85 19:20")
(PROG (V1)
(if (EQ COMPILE.CONTEXT (QUOTE EFFECT))
then (RETURN (COMP.PROGN A)))
[COND
(OFN (COND
((SETQ V1 (CONSTANTEXPRESSIONP (CADR A)))
(RETURN (COMP.COMPARENUM (LIST (CAR V1)
(CAR A))
TYPE OFN]
(COMP.EXPR (CAR A)
TYPE)
(COMP.DELFIX TYPE)
[COND
((AND OFN (SELECTQ (fetch OPNAME of (CAR CODE))
(CONST [SETQ V1 (KWOTE (fetch OPARG of (CAR CODE])
((AVAR HVAR GVAR FVAR)
(SETQ V1 CODE)
NIL)
NIL))
(RETURN (PROGN (COMP.DELPUSH)
(COMP.VAL1 (CDR A))
(COMP.DELFIX TYPE)
(COMP.VAL V1)
(COMP.STFN OFN 2]
(COMP.VAL1 (CDR A)
TYPE)
(COMP.DELFIX TYPE)
(COND
((AND OFN V1 (FMEMB (fetch OPNAME of (CAR CODE))
(QUOTE (CONST AVAR HVAR FVAR GVAR)))
(EQ (CDR CODE)
V1))
(swap (CAR CODE)
(CAR V1))
(COMP.STFN OFN 2))
(T (COMP.STFN FN 2])
(COMP.GETD
[LAMBDA (A) (* lmm
"13-Jul-84 21:19")
(COMP.VAL1 A)
(COND
((EQ COMPILE.CONTEXT (QUOTE EFFECT))
(COMP.STPOP)
(QUOTE NOVALUE))
((COMP.PREDP COMPILE.CONTEXT)
(COMP.STFN (SELECTQ (CAR COMPILE.CONTEXT)
((TJUMP FJUMP NFJUMP)
(* \DEFINEDP is the
same as GETD when the
value is used only for
NIL or T)
(QUOTE \DEFINEDP))
(CAR EXP))
1))
(T (COMP.STFN (CAR EXP)
1])
(COMP.FMEMB
[LAMBDA (A) (* lmm
"13-Jul-84 21:29")
(PROG NIL
[COND
((EQ COMPILE.CONTEXT (QUOTE EFFECT))
(RETURN (COMP.VALN A COMPILE.CONTEXT]
(COMP.EXPR (pop A))
(COMP.VAL1 A)
[COND
([AND (COMP.PREDP COMPILE.CONTEXT)
(EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(FMEMB (fetch OPNAME of COMPILE.CONTEXT)
(QUOTE (FJUMP TJUMP NFJUMP]
(RETURN (COMP.SELECTQ (LIST DONOTHING (LIST (PROG1 (fetch OPARG of (CAR CODE))
(COMP.DELPUSH))
T)
NIL]
(RETURN (COMP.STFN (CAR EXP)
2])
)
(PUTPROPS DMACRO PROPTYPE MACROS)
(* COMP.GETBASE)
(PUTPROPS \GETBASE DMACRO (APPLY* COMP.GETBASE NIL GETBASE.N))
(PUTPROPS \GETBASEBYTE DMACRO ((X N)
((OPCODES GETBASEBYTE)
X N)))
(PUTPROPS \GETBASEPTR DMACRO (APPLY* COMP.GETBASE NIL GETBASEPTR.N))
(PUTPROPS \HILOC DMACRO ((X)
((OPCODES HILOC)
X)))
(PUTPROPS \LOLOC DMACRO ((X)
((OPCODES LOLOC)
X)))
(PUTPROPS \PUTBASE DMACRO (APPLY* COMP.GETBASE T PUTBASE.N))
(PUTPROPS \PUTBASEBYTE DMACRO ((X N V)
((OPCODES PUTBASEBYTE)
X N V)))
(PUTPROPS \PUTBASEPTR DMACRO (APPLY* COMP.GETBASE T PUTBASEPTR.N))
(PUTPROPS \RPLPTR DMACRO (APPLY* COMP.GETBASE T RPLPTR.N))
(PUTPROPS \VAG2 DMACRO ((X Y)
((OPCODES VAG2)
X Y)))
(PUTPROPS \GETBITS DMACRO (APPLY* COMP.GETBASEBITS))
(PUTPROPS \PUTBITS DMACRO (APPLY* COMP.GETBASEBITS T))
(PUTPROPS \PUTBASEFIXP DMACRO (APPLY* COMP.GETBASE T PUTBASEFIXP.N))
(PUTPROPS \GETBASEFIXP DMACRO (APPLY* COMP.GETBASE NIL GETBASEFIXP.N))
(DEFINEQ
(COMP.GETBASE
[LAMBDA (A STFLG OPCODE) (* lmm
"29-Dec-84 11:58")
(COND
([AND STFLG (NOT (EQ COMPILE.CONTEXT (QUOTE EFFECT]
(COMP.VAL (CONS (LIST (QUOTE OPENLAMBDA)
(QUOTE (X N V))
(CONS (CAR EXP)
(QUOTE (X N V)))
(QUOTE V))
A)))
((AND (NOT STFLG)
(EQ COMPILE.CONTEXT (QUOTE EFFECT)))
(COMP.VALN A (QUOTE EFFECT)))
(T (PROG ((OFF 0))
(COMP.VAL (pop A))
(COND
((AND (OPT.CALLP (CAR CODE)
(QUOTE \ADDBASE)
2)
(EQ (fetch OPNAME of (CADR CODE))
(QUOTE CONST)))
(COMP.DELFN)
(add OFF (fetch OPARG of (CAR CODE)))
(COMP.DELPUSH)))
(COMP.EXPR (pop A)
(QUOTE (TYPE . FIX)))
(COND
([AND (EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(FIXP (fetch OPARG of (CAR CODE]
(add OFF (fetch OPARG of (CAR CODE)))
(COMP.DELPUSH))
(T (COMP.STFN (QUOTE \ADDBASE)
2)))
(COND
((OR (ILESSP OFF 0)
(IGREATERP OFF 255))
(COMP.STCONST OFF)
(COMP.STFN (QUOTE \ADDBASE)
2)
(SETQ OFF 0)))
[COND
(STFLG (COMP.EXPR (pop A)
(QUOTE (TYPE . FIX]
(MAPC A (FUNCTION COMP.EFFECT))
(RETURN (if (EQ OPCODE (QUOTE GETBASE.32))
then (if STFLG
then (HELP)
else (COMP.STFN (BQUOTE (OPCODES COPY GETBASE.N , OFF SWAP
GETBASE.N , (ADD1 OFF)
VAG2))
1))
else (COMP.STFN (LIST (QUOTE OPCODES)
OPCODE OFF)
(COND
(STFLG 2)
(T 1])
(COMP.GETBASEBITS
[LAMBDA (A STFLG) (* lmm
"29-Jun-84 08:25")
(COND
[[AND STFLG (NOT (EQ COMPILE.CONTEXT (QUOTE EFFECT]
(COMP.VAL (LIST (LIST (QUOTE OPENLAMBDA)
(QUOTE (X V))
(LIST (CAR EXP)
(QUOTE X)
(CADR A)
(CADDR A)
(QUOTE V))
(QUOTE V))
(CAR A)
(CADDDR A]
(T (PROG ((OFF (CADR A)))
(COMP.VAL (CAR A))
(COND
((AND (OPT.CALLP (CAR CODE)
(QUOTE \ADDBASE)
2)
(EQ (fetch OPNAME of (CADR CODE))
(QUOTE CONST)))
(COMP.DELFN)
(add OFF (fetch OPARG of (CAR CODE)))
(COMP.DELPUSH)))
(COND
((OR (ILESSP OFF 0)
(IGREATERP OFF 255))
(COMP.STCONST OFF)
(COMP.STFN (QUOTE \ADDBASE)
2)
(SETQ OFF 0)))
[COND
(STFLG (COMP.VAL (CADDDR A]
(RETURN (COMP.STFN [CONS (QUOTE OPCODES)
(COND
[(EQ (CADDR A)
15)
(COND
(STFLG (LIST (QUOTE PUTBASE.N)
OFF))
(T (LIST (QUOTE GETBASE.N)
OFF]
(T (COND
(STFLG (LIST (QUOTE PUTBITS.N.FD)
OFF
(CADDR A)))
(T (LIST (QUOTE GETBITS.N.FD)
OFF
(CADDR A]
(COND
(STFLG 2)
(T 1])
)
(DEFINEQ
(COMP.SPREADFN
[LAMBDA (2FN ARGS) (* lmm
"15-APR-82 22:26")
(COND
((NULL (CDR ARGS))
(CAR ARGS))
((NULL (CDDR ARGS))
(CONS 2FN ARGS))
(T (LIST 2FN (CAR ARGS)
(COMP.SPREADFN 2FN (CDR ARGS])
)
(PUTPROPS APPEND DMACRO [X (COND ((CDR X)
(COMP.SPREADFN (QUOTE \APPEND2)
X))
(T (LIST (QUOTE \APPEND2)
(CAR X])
(PUTPROPS NCONC DMACRO (X (COMP.SPREADFN (QUOTE \NCONC2)
X)))
(* CAPPLYFN)
(PUTPROPS NILAPPLY DMACRO (OPENLAMBDA (FN N)
(.PUSHNILS. N FN)))
(PUTPROPS .PUSHNILS. DMACRO (APPLY COMP.PUSHNILS))
(PUTPROPS SPREADAPPLY DMACRO [OPENLAMBDA (FN ARGLIST)
(PROG ((CNT 0))
(DECLARE (LOCALVARS . T))
(RETURN (.SPREAD. ARGLIST CNT FN])
(PUTPROPS .SPREAD. DMACRO (APPLY COMP.SPREAD))
(PUTPROPS SPREADAPPLY* DMACRO (X (LIST [LIST (QUOTE OPENLAMBDA)
(QUOTE ($$FN))
(CONS (QUOTE .APPLYFN.)
(APPEND (CDR X)
(LIST (LENGTH (CDR X))
(QUOTE $$FN]
(CAR X))))
(PUTPROPS .EVALFORM. DMACRO COMP.EVALFORM)
(PUTPROPS .CALLAFTERPUSHINGNILS. DMACRO (APPLY COMP.PUSHCALL))
(PUTPROPS APPLY* DMACRO COMP.APPLY*)
(PUTPROPS .SPREADCONS. DOPVAL (1 COPY CAR SWAP CDR))
(PUTPROPS .SWAPNIL. DOPVAL (2 SWAP))
(DEFINEQ
(COMP.PUSHNILS
[LAMBDA (N FN) (* lmm
"16-APR-82 00:39")
(COMP.EXPR N)
(PROG ((CHK (create TAG))
(LP (create TAG))
(LEV LEVEL)
(FR FRAME))
(COMP.STJUMP (QUOTE JUMP)
CHK)
(SETQ LEVEL LEV)
(SETQ FRAME FR)
(COMP.STTAG LP)
(COMP.STCONST)
(COMP.STFN (QUOTE .SWAPNIL.)
2)
(COMP.STCONST 1)
(COMP.STFN (QUOTE IDIFFERENCE)
2)
(COMP.STTAG CHK)
(COMP.STCOPY)
(COMP.STCONST 0)
(COMP.STFN (QUOTE IGREATERP)
2)
(COMP.STJUMP (QUOTE TJUMP)
LP)
(COMP.STPOP)
(COMP.VAL N)
(COMP.VAL FN)
(COMP.STFN (QUOTE .APPLYFN.)
2])
(COMP.SPREAD
[LAMBDA (L VAR FN APPLYTOEACH) (* lmm " 4-May-86 00:05")
[while (match L with ('MAPCAR & ('FUNCTION &@LITATOM))) do (push APPLYTOEACH (CADR (CADDR L]
(COMP.EXPR L)
(PROG ((LSTCHECK (create TAG))
(LP (create TAG))
(LEV LEVEL)
(FR FRAME))
(COMP.STJUMP (QUOTE JUMP)
LSTCHECK)
(SETQ LEVEL LEV)
(SETQ FRAME FR)
(COMP.STTAG LP)
(COMP.STFN (QUOTE (OPCODES COPY CAR))
1)
[for X in APPLYTOEACH do (if (SYMBOLP X)
then (COMP.STFN X 1)
else (LET ((N 1))
(for ARG in (CDR X) do (COMP.EXPR ARG)
(add N 1))
(COMP.STFN (CAR X)
N]
(COMP.STFN (QUOTE (OPCODES SWAP CDR))
1)
[COMP.EFFECT (LIST (QUOTE AND)
(LIST (QUOTE IGREATERP)
(LIST (QUOTE ADD1VAR)
VAR)
CALL-ARGUMENTS-LIMIT)
(QUOTE (LISPERROR "TOO MANY ARGUMENTS"]
(COMP.STTAG LSTCHECK)
(COMP.STJUMP (QUOTE NTJUMP)
LP)
(COMP.VAL VAR)
(COMP.VAL FN)
(RETURN (COMP.STFN (QUOTE .APPLYFN.)
2])
(COMP.EVALFORM
[LAMBDA NIL (* lmm
"29-Jun-84 08:25")
(* Special code for
compiling interpreter
(see function \EVALFORM
on LLNINTERP)%.
Assume *ARGVAL* bound
to 0, *FN* bound,
*TAIL* bound)
(OR (EQ COMPILE.CONTEXT (QUOTE RETURN))
(SHOULDNT)) (* Must be in return
context, since
otherwise would have to
pop off *ARGVAL* value)
(PROG ((DONE (create TAG))
(LP (create TAG)))
(COMP.STCONST (QUOTE *ARGVAL*)) (* for BLIPVAL to find)
(COMP.STTAG LP)
[COMP.VAL (QUOTE (LISTP (SETQ *TAIL* (CDR *TAIL*] (* *TAIL* initially
bound to entire form.)
(COMP.STJUMP (QUOTE FJUMP)
DONE)
[COMP.VAL (QUOTE (\EVAL (CAR *TAIL*] (* evaluate this
argument)
[COMP.EFFECT (LIST (QUOTE AND)
(LIST (QUOTE IGREATERP)
(QUOTE (SETQ *ARGVAL* (ADD1 *ARGVAL*)))
MAXARGS)
(LIST (QUOTE LISPERROR)
(QUOTE "TOO MANY ARGUMENTS")
(QUOTE *TAIL*] (* increment counter of
number of values)
(SETQ LEVEL (SUB1 LEVEL)) (* fool level check;
the value of the \EVAL
is left on the stack,
even though the
compiler doesn't think
so)
(COMP.STJUMP (QUOTE JUMP)
LP)
(COMP.STTAG DONE) (* there are really
*ARGVAL* values on the
stack)
[COMP.EFFECT (QUOTE (AND *TAIL* (LISPERROR "UNUSUAL CDR ARG LIST" *TAIL*]
[COMP.VAL (QUOTE (PROG1 *ARGVAL* (SETQ *ARGVAL*] (* push number of
arguments -
mark frame as done
(see \DEADBLIPFRAME on
LLNINTERP))
(COMP.VAL (QUOTE *FN*)) (* push name of
function to call)
(COMP.STFN (QUOTE .APPLYFN.)
2) (* this will execute
applyfn opcode, which
really takes N+2 args
even though compiler
thinks it takes 2)
(RETURN (COMP.STRETURN])
(COMP.PUSHCALL
[LAMBDA (N FORM) (* lmm
"16-APR-82 00:39")
(COMP.VAL N)
(PROG ((CHK (create TAG))
(LP (create TAG))
(LEV LEVEL)
(FR FRAME))
(COMP.STJUMP (QUOTE JUMP)
CHK)
(SETQ LEVEL LEV)
(SETQ FRAME FR)
(COMP.STTAG LP)
(COMP.STCONST)
(COMP.STFN (QUOTE .SWAPNIL.)
2)
(COMP.STCONST 1)
(COMP.STFN (QUOTE IDIFFERENCE)
2)
(COMP.STTAG CHK)
(COMP.STCOPY)
(COMP.STCONST 0)
(COMP.STFN (QUOTE IGREATERP)
2)
(COMP.STJUMP (QUOTE TJUMP)
LP)
(COMP.STPOP)
(RETURN (COMP.EXP1 FORM])
(COMP.APPLY*
[LAMBDA (A) (* lmm
"13-Jul-84 21:18")
(PROG (FN)
(replace EXTCALL of FRAME with T)
(COND
([AND (EQ (CAR (LISTP (CAR A)))
(QUOTE FUNCTION))
(NULL (CDDAR A))
(LISTP (SETQ FN (CADR (CAR A]
(SELECTQ (ARGTYPE FN)
((0 2)
[RETURN (COMP.EXP1 (CONS FN (CDR A])
(3 (* APPLY* of NLAMBDA
nospread)
(* AND (LITATOM FN)
(RETURN (COMP.CALL FN
(LIST (CONS (QUOTE LIST)
(CDR A))) 0)))
)
(1 (* APPLY* of NLAMBDA
spread)
(* AND (LITATOM FN)
(RETURN (COMP.CALL FN
(CDR A) 0)))
)
NIL)))
(RETURN (COMP.EXP1 (BQUOTE ((OPENLAMBDA (, (SETQ FN (GENSYM)))
((OPCODES CHECKAPPLY* APPLYFN)
,@(CDR A)
,
(LENGTH (CDR A))
, FN))
,
(CAR A])
)
(* for ERRORSET ARG and SETARG)
(PUTPROPS .ERRSETQ. DMACRO (APPLY COMP.ERRORSET))
(PUTPROPS ARG DMACRO COMP.ARG)
(PUTPROPS SETARG DMACRO COMP.SETARG)
(PUTPROPS NAMEDLET DMACRO COMP.NAMEDLET)
(DEFINEQ
(COMP.ERRORSET
[LAMBDA (E V W) (* lmm
" 1-Sep-84 11:38")
(* A call to ERRORSET)
(PROG [(FN (COMP.LAM1 (APPEND [QUOTE (LAMBDA NOBIND (\CALLME (QUOTE ERRORSET]
(COND
((OR (EQ COMPILE.CONTEXT (QUOTE EFFECT))
(AND (COMP.PREDP COMPILE.CONTEXT)
(SELECTQ (CAR COMPILE.CONTEXT)
((TJUMP FJUMP)
T)
NIL)))
(LIST E T))
(T (LIST (LIST (QUOTE LIST)
E]
(RETURN (COMP.CALL FN (LIST (KWOTE (LIST FN))
(KWOTE V)
(KWOTE W))
0])
(COMP.ARG
[LAMBDA (A) (* bvm:
"15-Oct-85 18:18")
(COND
((AND (EQ COMPILE.CONTEXT (QUOTE EFFECT)))
(COMP.PROGN A))
[(AND (EQ COMTYPE 2)
(EQ (COMP.LOOKUPVAR (CAR A))
(CAR ARGVARS)))
(COMP.VAL1 (CDR A))
(COND
((AND COMPILE.ARG.FAST.FLG (EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
[FIXP (SETQ A (fetch OPARG of (CAR CODE]
(IGREATERP A 0)
(ILEQ A 255))
(COMP.DELPUSH)
(COMP.STFN [COND
((IGREATERP A (OPCOUNT (QUOTE IVAR)))
(LIST (QUOTE OPCODES)
(QUOTE IVARX)
(LLSH (SUB1 A)
1)))
(T (LIST (QUOTE OPCODES)
(LIST (QUOTE IVAR)
(SUB1 A]
0))
(T (COMP.STFN (QUOTE (OPCODES ARG0))
1]
(T (* unreasonable ARG)
(COMP.CALL (QUOTE ARG)
(CONS (KWOTE (CAR A))
(CDR A))
0])
(COMP.SETARG
[LAMBDA (A) (* lmm
" 6-Dec-85 13:17")
(COND
[(AND (EQ COMTYPE 2)
(EQ (COMP.LOOKUPVAR (CAR A))
(CAR ARGVARS)))
(COMP.VAL (CADR A))
(LET [(ARG (fetch OPARG of (CAR CODE]
(COND
((AND COMPILE.ARG.FAST.FLG (EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(FIXP ARG)
(IGREATERP ARG 0)
(ILEQ ARG 255))
(COMP.DELPUSH)
(COMP.VAL1 (CDDR A))
(COMP.STFN (LIST (QUOTE OPCODES)
(QUOTE IVARX←)
(TIMES (SUB1 ARG)
2))
1))
(T (COMP.VAL1 (CDDR A))
(COMP.STFN (QUOTE \SETARG0)
2]
(T (* unreasonable ARG)
(COMP.CALL (QUOTE \SETARG)
(CONS (KWOTE (CAR A))
(CDR A))
0])
(COMP.NAMEDLET
[LAMBDA (ARGS) (* lmm
" 8-MAY-82 13:15")
(PROG [(FN (COMP.LAM1 (CONS (QUOTE LAMBDA)
(CONS (MAPCAR (CAR (CDR ARGS))
(FUNCTION CAR))
(CONS (LIST (QUOTE \CALLME)
(KWOTE (CAR ARGS)))
(CDR (CDR ARGS]
(RETURN (COMP.CALL FN [MAPCAR (CAR (CDR ARGS))
(FUNCTION (LAMBDA (X)
(COND
((CDR (CDR X))
(CONS (QUOTE PROG1)
(CDR X)))
(T (CAR (CDR X]
0])
)
(PUTPROPS LOADTIMECONSTANT DMACRO [X (LIST (QUOTE QUOTE)
(CONS LOADTIMECONSTANTMARKER (CAR X])
(RPAQQ LOADTIMECONSTANTMARKER "LoadTimeConstant")
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(ACCESSFNS DASM [(FREEVARINDEX (GETHASH DATUM FVINDEXHARRAY)
(PUTHASH DATUM NEWVALUE FVINDEXHARRAY))
(VARINDEX (GETHASH DATUM VCA)
(PUTHASH DATUM NEWVALUE VCA))
(CLEAR (PROGN (OPT.INITHASH VCA)
(OPT.INITHASH FVINDEXHARRAY] (* for alto assembler)
)
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS FVINDEXHARRAY)
)
(DECLARE: EVAL@COMPILE
[PUTPROPS PARENTP MACRO (LAMBDA (X Y)
(PROG NIL LP (RETURN (OR (EQ X Y)
(AND (SETQ X (fetch PARENT of X))
(GO LP]
[PUTPROPS AST MACRO ((X)
(SETQ CD (CONS X CD))
(SETQ CODELOC (ADD1 CODELOC]
[PUTPROPS OPCOUNT MACRO (LAMBDA (X)
(ADD1 (LET [(OP (fetch OP# of (\FINDOP X]
(IDIFFERENCE (CADR OP)
(CAR OP]
)
(DECLARE: EVAL@COMPILE
[PUTPROPS CHECKRANGE MACRO ((X N MSG)
(COND ((IGREATERP X (CONSTANT N))
(COMPERRM (LIST X MSG (QUOTE %,)
(QUOTE LIMIT)
(QUOTE IS)
(CONSTANT N]
)
DONTEVAL@LOAD
(FILESLOAD (LOADCOMP)
BYTECOMPILER LLCODE)
)
(PUTPROPS DLAP COPYRIGHT ("Xerox Corporation" T 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4855 47437 (C.FLOATBOX 4865 . 5189) (C.FLOATUNBOX 5191 . 5503) (DASSEM.DASSEM 5505 .
26692) (DASSEM.DWRITEFN 26694 . 33709) (DASSEM.SAVELOCALVARS 33711 . 33755) (DASSEM.DSTOREFNDEF 33757
. 43057) (DASSEM.DPRINTLAP 43059 . 43542) (DASSEM.EQCONSTANTP 43544 . 43848) (DASSEM.MATCHVARS 43850
. 45747) (DASSEM.COUNTVARS 45749 . 46307) (DASSEM.CANSHAREBINDING 46309 . 47435)) (47600 53066 (
DASSEM.DASMBIND 47610 . 48415) (DASSEM.DSTOREFN 48417 . 48771) (DASSEM.ASMAJ 48773 . 53064)) (62147
63350 (DASSEM.CLEANFNTEST 62157 . 63348)) (72012 79812 (COMP.RPLACD 72022 . 74034) (COMP.SHIFT 74036
. 76214) (COMP.COMPARENUM 76216 . 77846) (COMP.GETD 77848 . 78816) (COMP.FMEMB 78818 . 79810)) (81084
86409 (COMP.GETBASE 81094 . 83768) (COMP.GETBASEBITS 83770 . 86407)) (86410 86799 (COMP.SPREADFN
86420 . 86797)) (88387 98633 (COMP.PUSHNILS 88397 . 89345) (COMP.SPREAD 89347 . 91028) (COMP.EVALFORM
91030 . 95643) (COMP.PUSHCALL 95645 . 96521) (COMP.APPLY* 96523 . 98631)) (98853 103808 (COMP.ERRORSET
98863 . 100032) (COMP.ARG 100034 . 101476) (COMP.SETARG 101478 . 102757) (COMP.NAMEDLET 102759 .
103806)))))
STOP