(FILECREATED "22-May-86 12:23:06" {ERIS}<TAMARIN>WORK>DT>D2T.;20 38481
changes to: (FNS D2T.EXPANDUNBIND)
previous date: "13-May-86 17:08:51" {ERIS}<TAMARIN>WORK>DT>D2T.;19)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT D2TCOMS)
(RPAQQ D2TCOMS ((* * see associated doc: D2T.tedit)
(GLOBALVARS \D2T.LABEL2BSTACK \D2T.LABELSEEN?)
(INITVARS \D2T.LABEL2BSTACK \D2T.LABELSEEN?)
(FNS D2T)
(FNS D2T.PASSDECLS D2T.PASSFNDECL D2T.PASSVARDECLS)
(FNS D2T.PASSINSTRS D2T.PASSINSTRSINNER D2T.CLUMP D2T.EXPAND D2T.GENERICIZE)
(FNS D2T.EXPANDBIND D2T.EXPANDUNBIND D2T.EXPANDIVAR D2T.EXPANDIVAR← D2T.EXPANDFNX)
(FNS D2T.EXPANDGETBASE.N D2T.EXPANDPUTBASE.N D2T.EXPANDGETBITS.N.FD
D2T.EXPANDPUTBITS.N.FD)
(FNS D2T.ADDLPVAR)
(FNS D2T.PASSLABEL D2T.NOTELABEL)
(FNS D2T.ACCEPTERRORS D2T.HELP D2T.WARN D2T.SETSEQ)))
(* * see associated doc: D2T.tedit)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \D2T.LABEL2BSTACK \D2T.LABELSEEN?)
)
(RPAQ? \D2T.LABEL2BSTACK NIL)
(RPAQ? \D2T.LABELSEEN? NIL)
(DEFINEQ
(D2T
[LAMBDA (IL ERRFILE) (* jmh "15-Jan-86 10:25")
(* * IL is a LAP list -- error messages printed to <OR ERRFILE T> --
also see D2T.HELP)
(* * returns (#errs . instrlist) -- ERRS accumulates error messages for this
instr -- the phase-subrs here eat off the head of IL, TCONC onto OLT --
FNTYPE is really only used for IVAR processing in case of Lambda*s --
IVARS0 is the list from the function declaration, or T if can't decipher it,
for consistency-checking only -- IVARS PVARS FVARS come from the specvar &
local declarations)
(DECLARE (SPECVARS IL))
(LET ((NERRS 0)
(OLT (CONS))
OUTEROLT ERRS FNTYPE IVARS0 IVARS PVARS FVARS)
(DECLARE (SPECVARS NERRS ERRFILE OUTEROLT ERRS FNTYPE OLT IVARS0 IVARS PVARS FVARS))
(* *)
(D2T.PASSDECLS)
(SETQ OUTEROLT OLT)
(D2T.PASSINSTRS)
(* *)
(CONS NERRS (CAR OUTEROLT])
)
(DEFINEQ
(D2T.PASSDECLS
[LAMBDA NIL (* jmh "23-Nov-85 16:04")
(DECLARE (USEDFREE IL OLT ERRS FNTYPE IVARS0 IVARS))
(D2T.PASSFNDECL)
(if (EQ (CAR (CAR IL))
(QUOTE DFNHEADER:))
then (TCONC OLT (pop IL)))
(D2T.PASSVARDECLS (QUOTE (LOCAL: CODE:)))
(if (AND (LISTP IL)
(EQ (CAR IL)
(QUOTE LOCAL:)))
then (TCONC OLT (pop IL)))
(D2T.PASSVARDECLS (QUOTE (CODE:)))
[if (NLISTP IL)
then (TCONC OLT (LIST "at end"))
(push ERRS "no CODE:")
elseif (NEQ (CAR IL)
(QUOTE CODE:))
then (D2T.HELP "no CODE:")
else (TCONC OLT (pop IL))
(if (NLISTP IL)
then (TCONC OLT (LIST "at end"))
(push ERRS "no fn body")
else (if [NOT (OR (EQ IVARS0 T)
(SELECTQ FNTYPE
(NIL T)
([LAMBDA NLAMBDA]
(D2T.SETSEQ IVARS0 IVARS))
(NLAMBDA* (EQUAL IVARS (LIST IVARS0)))
(LAMBDA* (OR (NULL IVARS)
(EQUAL IVARS (LIST IVARS0))))
(D2T.HELP "bad fnType" FNTYPE]
then (push ERRS "IVARS: not= fn decl's ivars"]
(D2T.ACCEPTERRORS])
(D2T.PASSFNDECL
[LAMBDA NIL
(DECLARE (USEDFREE IL OLT ERRS FNTYPE IVARS0)) (* jmh "28-Jan-86 11:21")
(SETQ IVARS0 T) (* IVARS0=T means "ill-formed: ignore")
[if [OR (NLISTP IL)
(NLISTP (CAR IL))
(NOT (MEMB (CAR (CAR IL))
(QUOTE (LAMBDA: NLAMBDA:]
then (TCONC OLT (LIST "at beginning"))
(push ERRS "doesn't start with N/LAMBDA: declaration")
else (LET ((I (pop IL)))
(TCONC OLT I)
(if [OR (NLISTP (CDR I))
(NULL (CADR I))
(NOT (LITATOM (CADR I]
then (push ERRS "bad fn name"))
(SETQ IVARS0 (if [AND (LISTP (CDR I))
(LISTP (CDDR I))
(OR (LISTP (CADDR I))
(LITATOM (CADDR I]
then (CADDR I)
else (push ERRS "bad arg list")
T))
(SETQ FNTYPE (if [AND (NEQ IVARS0 NIL)
(NEQ IVARS0 T)
(OR (NLISTP IVARS0)
(AND (EQ 2 (LENGTH IVARS0))
(OR (LITATOM (CAR IVARS0))
(STRINGP (CAR IVARS0)))
(NUMBERP (CADR IVARS0]
then (if (EQ (CAR I)
(QUOTE LAMBDA:))
then (QUOTE LAMBDA*)
else (QUOTE NLAMBDA*))
else (if (EQ (CAR I)
(QUOTE LAMBDA:))
then (QUOTE LAMBDA)
else (QUOTE NLAMBDA]
(D2T.ACCEPTERRORS])
(D2T.PASSVARDECLS
[LAMBDA (STOPLIST)
(DECLARE (USEDFREE IL OLT ERRS FNTYPE IVARS PVARS FVARS))(* jmh " 9-Dec-85 12:22")
(while (AND (LISTP IL)
(NOT (MEMB (CAR IL)
STOPLIST))) bind I
do (SETQ I (pop IL))
(if (LISTP I)
then [SELECTQ (CAR I)
(IVARS: (SETQ IVARS (APPEND (CDR I)
IVARS))
(TCONC OLT (CONS (QUOTE VARS:)
(CDR I))))
(PVARS: [if (AND (MEMB FNTYPE (QUOTE (LAMBDA* NLAMBDA*)))
(MEMB IVARS0 (CDR I)))
then (TCONC OLT (QUOTE (* forT2D: arglistIsPvar]
(SETQ PVARS (APPEND (CDR I)
PVARS))
(TCONC OLT (CONS (QUOTE VARS:)
(CDR I))))
(FVARS: (SETQ FVARS (APPEND (CDR I)
FVARS))
(TCONC OLT I))
(PROGN (TCONC OLT I)
(if (NEQ (CAR I)
(QUOTE *))
then (push ERRS "not variable declaration"]
else (TCONC OLT I)
(push ERRS "not variable declaration"))
(D2T.ACCEPTERRORS])
)
(DEFINEQ
(D2T.PASSINSTRS
[LAMBDA NIL (* jmh "15-Jan-86 10:57")
(* * eat instrs off head of IL, TCONC output to OUTEROLT --
multiple passes: until stack modelling is complete enough for D/UNBIND)
(* * some variables -- SMU? = Stack Modelling Unknown anywhere critical this
pass? <ie a D/UNBIND failed or a label became positively ambiguous wrt stack
modelling> -- SMUAE? = Stack Modelling Unknowns Are Errors this pass? <for
D/UNBINDs> -- SMMP? = Stack Modelling Made Progress this pass? <some label got
stack info that had none, or went positively ambiguous> --
NFML = Number For Making Labels <manufactured labels have to be the same each
pass, so we don't use GENSYM>)
(* * the \D2T.LABEL2BSTACK part of the stack modelling information accumulates
from pass to pass -- thus code generation must be done so that a label's stack
information never changes, once known, except to go "ambiguous" --
the \D2T.LABELSEEN? part of the stack modelling information is rebuilt each
pass, so that errors can be caught on any pass)
(DECLARE (GLOBALVARS \D2T.LABEL2BSTACK \D2T.LABELSEEN?)
(USEDFREE NERRS IL OUTEROLT))
[OR \D2T.LABEL2BSTACK (SETQ \D2T.LABEL2BSTACK (HASHARRAY (LENGTH IL]
(CLRHASH \D2T.LABEL2BSTACK)
[OR \D2T.LABELSEEN? (SETQ \D2T.LABELSEEN? (HASHARRAY (LENGTH IL]
(LET ((OUTERNERRS NERRS)
INNEROL SMU? SMUAE? SMMP? NFML)
(DECLARE (SPECVARS SMU? SMUAE? SMMP? NFML))
(repeatuntil (OR (NEQ 0 NERRS)
(NOT SMU?)) do (SETQ SMU?)
(SETQ SMMP?)
(SETQ NFML 0)
(SETQ INNEROL (D2T.PASSINSTRSINNER IL))
(SETQ SMUAE? (NOT SMMP?))
(* stack modelling unknowns become
errors after a pass in which no
progress was made in the stack
modelling))
(LCONC OUTEROLT INNEROL)
(add NERRS OUTERNERRS)
(if (AND (NEQ 0 NERRS)
SMU?)
then (D2T.ACCEPTERRORS)
(TCONC OUTEROLT (LIST "*D2T aborted stack modelling*"])
(D2T.PASSINSTRSINNER
[LAMBDA (IL) (* jmh "27-Mar-86 13:52")
(* * input instr list IL, return modified instr list OL --
BSTACK is either T-terminated list of (CONS bind-label vars-bound) or
NIL=unknown or ?=positively ambiguous)
(DECLARE (GLOBALVARS \D2T.LABELSEEN?)
(SPECVARS IL)
(USEDFREE ERRS))
(CLRHASH \D2T.LABELSEEN?)
(D2T.ACCEPTERRORS) (* before moving to inner OLT)
(LET ((BSTACK T)
(OLT (CONS)))
(DECLARE (SPECVARS BSTACK OLT))
[while (LISTP IL) bind I JL
do (if (SETQ JL (D2T.CLUMP))
then (* D2T.CLUMP has popped IL)
(for J in JL do (if (NLISTP J)
then (D2T.PASSLABEL J)
else (D2T.GENERICIZE J)))
else (SETQ I (pop IL))
(if (NLISTP I)
then (D2T.PASSLABEL I)
else (SETQ JL (D2T.EXPAND I))
(if (AND ERRS JL)
then (TCONC OLT (CAR JL))
(D2T.ACCEPTERRORS)
(LCONC OLT (CDR JL))
else (for J in JL do (if (NLISTP J)
then (D2T.PASSLABEL J)
else (D2T.GENERICIZE J]
(CAR OLT])
(D2T.CLUMP
[LAMBDA NIL (* jmh "27-Mar-86 14:02")
(* * if first of IL is a shift, collect shifts off the front of IL, return
equivalent list of instrs)
(DECLARE (USEDFREE IL))
(if (MEMB (CAAR IL)
(QUOTE (LLSH1 LLSH8 LRSH1 LRSH8)))
then [LET (I (N 0))
[while [AND (LISTP IL)
(LISTP (SETQ I (CAR IL)))
(MEMB (CAR I)
(QUOTE (LLSH1 LLSH8 LRSH1 LRSH8]
do (pop IL)
(add N (SELECTQ (CAR I)
(LLSH1 1)
(LLSH8 8)
(LRSH1 -1)
(LRSH8 -8)
(D2T.HELP "impossible shift op here"]
(LIST (if (MINUSP N)
then (LIST (QUOTE LRSH.N)
(MINUS N))
else (LIST (QUOTE LLSH.N)
N]
else NIL])
(D2T.EXPAND
[LAMBDA (INSTR) (* jmh "13-May-86 11:18")
(* * returns list of instrs -- if any errors noted here then the returned list won't be treated further, except to
attach the errors to its CAR)
(DECLARE (USEDFREE FNTYPE NFML))
(SELECTQ (CAR INSTR)
(BIND (D2T.EXPANDBIND INSTR))
((UNBIND DUNBIND)
(D2T.EXPANDUNBIND INSTR))
((IVAR IVARX)
(if (EQ FNTYPE (QUOTE LAMBDA*))
then (D2T.EXPANDIVAR INSTR)
else (LIST INSTR)))
(IVARX← (if (EQ FNTYPE (QUOTE LAMBDA*))
then (D2T.EXPANDIVAR← INSTR)
else (LIST INSTR)))
(FNX (D2T.EXPANDFNX INSTR))
(NOP (LET [(LABEL (PACK* (add NFML 1)
(QUOTE $NOP]
(LIST (LIST (QUOTE JUMP)
LABEL)
LABEL)))
(GETBASE.N (D2T.EXPANDGETBASE.N INSTR))
(PUTBASE.N (D2T.EXPANDPUTBASE.N INSTR))
(GETBITS.N.FD (D2T.EXPANDGETBITS.N.FD INSTR))
(PUTBITS.N.FD (D2T.EXPANDPUTBITS.N.FD INSTR))
(LIST INSTR])
(D2T.GENERICIZE
[LAMBDA (I) (* jmh "29-Mar-86 11:43")
(* * TCONC possibly-genericized instr onto OLT --
also do one-to-one translations)
(DECLARE (USEDFREE BSTACK OLT))
(TCONC OLT (SELECTQ (CAR I)
((IVAR IVARX)
(CONS (QUOTE VAR)
(CDR I)))
((IVAR← IVARX←)
(CONS (QUOTE VAR←)
(CDR I)))
((IVAR←↑ IVARX←↑)
(CONS (QUOTE VAR←↑)
(CDR I)))
((PVAR PVARX)
(CONS (QUOTE VAR)
(CDR I)))
((PVAR← PVARX←)
(CONS (QUOTE VAR←)
(CDR I)))
((PVAR←↑ PVARX←↑)
(CONS (QUOTE VAR←↑)
(CDR I)))
((FVAR FVARX)
(CONS (QUOTE FVAR)
(CDR I)))
((FVAR← FVARX←)
(CONS (QUOTE FVAR←)
(CDR I)))
((FVAR←↑ FVARX←↑)
(CONS (QUOTE FVAR←↑)
(CDR I)))
((JUMP JUMPX JUMPXX)
(D2T.NOTELABEL (CADR I))
(SETQ BSTACK NIL)
(CONS (QUOTE JUMP)
(CDR I)))
((FJUMP FJUMPX FJUMPXX)
(D2T.NOTELABEL (CADR I))
(CONS (QUOTE FJUMP)
(CDR I)))
((TJUMP TJUMPX TJUMPXX)
(D2T.NOTELABEL (CADR I))
(CONS (QUOTE TJUMP)
(CDR I)))
((NFJUMP NFJUMPX NFJUMPXX)
(D2T.NOTELABEL (CADR I))
(CONS (QUOTE NFJUMP)
(CDR I)))
((NTJUMP NTJUMPX NTJUMPXX)
(D2T.NOTELABEL (CADR I))
(CONS (QUOTE NTJUMP)
(CDR I)))
('0 (LIST (QUOTE SIC)
0))
('1 (LIST (QUOTE SIC)
1))
((SIC SNIC SICX)
(CONS (QUOTE SIC)
(CDR I)))
(GCONST (CONS (LET ((TFIXPSIZE (LSH 1 29)))
(if (AND (NUMBERP (CADR I))
(IGEQ (CADR I)
(IMINUS TFIXPSIZE))
(ILESSP (CADR I)
TFIXPSIZE))
then (QUOTE ICONST)
else (QUOTE PCONST)))
(CDR I)))
(FN0 (CONS (QUOTE FN)
(CONS 0 (CDR I))))
(FN1 (CONS (QUOTE FN)
(CONS 1 (CDR I))))
(FN2 (CONS (QUOTE FN)
(CONS 2 (CDR I))))
(FN3 (CONS (QUOTE FN)
(CONS 3 (CDR I))))
(FN4 (CONS (QUOTE FN)
(CONS 4 (CDR I))))
(FNX (CONS (QUOTE FN)
(CDR I)))
(CHECKAPPLY* (QUOTE (* forT2D: CHECKAPPLY*)))
(RETURN (SETQ BSTACK NIL)
I)
I))
(D2T.ACCEPTERRORS])
)
(DEFINEQ
(D2T.EXPANDBIND
[LAMBDA (INSTR)
(DECLARE (USEDFREE BSTACK NFML)) (* jmh "29-Jan-86 12:22")
(LET [(LABEL (PACK* (add NFML 1)
(QUOTE $BIND)))
(OLT (TCONC NIL (CONS (QUOTE *)
INSTR]
(for V in (REVERSE (CADR INSTR)) do (TCONC OLT (LIST (QUOTE PVAR←↑)
V)))
[if (CADDR INSTR)
then (TCONC OLT (LIST (QUOTE 'NIL)))
(for V in (CDR (CADDR INSTR)) do (TCONC OLT (LIST (QUOTE PVAR←)
V)))
(TCONC OLT (LIST (QUOTE PVAR←↑)
(CAR (CADDR INSTR]
(TCONC OLT LABEL)
[if (AND BSTACK (NEQ BSTACK (QUOTE ?)))
then (push BSTACK (CONS LABEL (APPEND (CADR INSTR)
(CADDR INSTR]
(TCONC OLT (LIST (QUOTE *)
(QUOTE forT2D:)
(QUOTE BIND)))
(CAR OLT])
(D2T.EXPANDUNBIND
[LAMBDA (INSTR)
(DECLARE (USEDFREE BSTACK ERRS SMU? SMUAE?)) (* jmh "21-May-86 15:39")
(LET [(OLT (TCONC NIL (CONS (QUOTE *)
INSTR]
[if (NULL BSTACK)
then (SETQ SMU? T)
(if SMUAE?
then (push ERRS "binding stack unknown"))
elseif (EQ BSTACK (QUOTE ?))
then (push ERRS "binding stack ambiguous")
elseif (NLISTP BSTACK)
then (push ERRS "binding stack underflow")
else (LET ((B (pop BSTACK)))
[if (CDR B)
then (TCONC OLT (LIST (QUOTE 'UNBOUND)))
(for V in (CDR (CDR B)) do (TCONC OLT
(LIST (QUOTE
PVAR←)
V)))
(TCONC OLT (LIST (QUOTE PVAR←↑)
(CAR (CDR B]
(TCONC OLT (LIST (CAR INSTR)
(CAR B]
(CAR OLT])
(D2T.EXPANDIVAR
[LAMBDA (INSTR) (* jmh "23-Nov-85 15:59")
(* * called only if lambda* -- returns list of instructions)
(DECLARE (USEDFREE ERRS))
(LET [(ARGNR (if (AND (ILEQ 2 (LENGTH INSTR))
(NUMBERP (CADR INSTR)))
then (ADD1 (CADR INSTR))
else (push ERRS "arg not numeric"]
(LIST (CONS (QUOTE *)
INSTR)
(LIST (QUOTE SICX)
ARGNR)
(LIST (QUOTE ARG0])
(D2T.EXPANDIVAR←
[LAMBDA (INSTR) (* jmh "23-Nov-85 15:59")
(* * called only if lambda* -- returns list of instructions)
(DECLARE (USEDFREE OUTEROLT ERRS IVARS LOCALS?))
(LET [(ARGNR (if (AND (ILEQ 2 (LENGTH INSTR))
(NUMBERP (CADR INSTR)))
then (ADD1 (CADR INSTR))
else (push ERRS "arg not numeric"]
(LIST (CONS (QUOTE *)
INSTR)
(LIST (QUOTE SICX)
ARGNR)
(LIST (QUOTE SWAP))
(LIST (QUOTE FN2)
(QUOTE \SETARG0])
(D2T.EXPANDFNX
[LAMBDA (INSTR) (* jmh " 9-Dec-85 11:39")
(if [NOT (AND (LISTP (CDR INSTR))
(NUMBERP (CADR INSTR))
(ILEQ 0 (CADR INSTR]
then (push ERRS "bad #args")
(LIST INSTR)
elseif (IGEQ 6 (CADR INSTR))
then (LIST INSTR)
else (LIST (QUOTE (* forT2D: FN7))
(LIST (QUOTE SICX)
(IDIFFERENCE (CADR INSTR)
6))
(QUOTE (FN1 \VectorizeN))
(CONS (QUOTE FNX)
(CONS 7 (CDDR INSTR])
)
(DEFINEQ
(D2T.EXPANDGETBASE.N
[LAMBDA (INSTR) (* jmh "31-Mar-86 15:33")
(* * macro-expand a GETBASE.N instr in terms of byte accesses and shifts,
returning a list of instrs)
(LET ((BYTEOFFSET (ITIMES 2 (CADR INSTR)))
(VARNAME (D2T.ADDLPVAR "D2T$temp1")))
(D2T.WARN INSTR)
(LIST (CONS (QUOTE *)
INSTR)
(QUOTE (COPY))
(LIST (QUOTE SIC)
BYTEOFFSET)
(QUOTE (GETBASEBYTE))
(QUOTE (LLSH.N 8))
(LIST (QUOTE VAR←↑)
VARNAME)
(LIST (QUOTE SIC)
(ADD1 BYTEOFFSET))
(QUOTE (GETBASEBYTE))
(LIST (QUOTE VAR)
VARNAME)
(QUOTE (LOGOR2])
(D2T.EXPANDPUTBASE.N
[LAMBDA (INSTR) (* jmh "31-Mar-86 15:33")
(* * macro-expand a PUTBASE.N instr in terms of byte accesses and shifts,
returning a list of instrs)
(* * the code generated has to return PTR like PUTBASE.N, not BYTE like
PUTBASEBYTE)
(LET ((BYTEOFFSET (ITIMES 2 (CADR INSTR)))
(VARNAME1 (D2T.ADDLPVAR "D2T$temp1"))
(VARNAME2 (D2T.ADDLPVAR "D2T$temp2")))
(D2T.WARN INSTR)
(LIST (CONS (QUOTE *)
INSTR)
(LIST (QUOTE VAR←↑)
VARNAME1)
(LIST (QUOTE VAR←)
VARNAME2)
(LIST (QUOTE SIC)
BYTEOFFSET)
(LIST (QUOTE VAR)
VARNAME1)
(QUOTE (LRSH.N 8))
(QUOTE (PUTBASEBYTE))
(QUOTE (POP))
(LIST (QUOTE VAR)
VARNAME2)
(LIST (QUOTE SIC)
(ADD1 BYTEOFFSET))
(LIST (QUOTE VAR)
VARNAME1)
(QUOTE (PUTBASEBYTE))
(QUOTE (POP))
(LIST (QUOTE VAR)
VARNAME2])
(D2T.EXPANDGETBITS.N.FD
[LAMBDA (INSTR) (* jmh "27-Mar-86 14:29")
(* * macro-expand a GETBITS.N.FD instr in terms of byte accesses, shifts, and
masks, returning a list of instrs)
(LET ((BYTEOFFSET (ITIMES 2 (CADR INSTR)))
(LBIT (CADDR INSTR))
(NBITS (CADDDR INSTR))
(OLT (CONS))
NBITSGOTTEN SHIFTRIGHT)
(* * comment with original instr)
(TCONC OLT (CONS (QUOTE *)
INSTR))
(* * generate code to get some bits containing the desired bits on the stack,
and note to ourselves how many bits we got and how far right to shift these
bits to right-align the desired bits)
[if (IGEQ LBIT 8)
then (* right byte only)
[LCONC OLT (LIST (LIST (QUOTE SIC)
(ADD1 BYTEOFFSET))
(QUOTE (GETBASEBYTE]
(SETQ NBITSGOTTEN 8)
(SETQ SHIFTRIGHT (IDIFFERENCE 16 (IPLUS LBIT NBITS)))
elseif (ILEQ (IPLUS LBIT NBITS)
8)
then (* left byte only)
[LCONC OLT (LIST (LIST (QUOTE SIC)
BYTEOFFSET)
(QUOTE (GETBASEBYTE]
(SETQ NBITSGOTTEN 8)
(SETQ SHIFTRIGHT (IDIFFERENCE 8 (IPLUS LBIT NBITS)))
else (* both bytes needed)
[LET ((VARNAME (D2T.ADDLPVAR "D2T$temp1")))
(LCONC OLT (LIST (QUOTE (COPY))
(LIST (QUOTE SIC)
BYTEOFFSET)
(QUOTE (GETBASEBYTE))
(QUOTE (LLSH.N 8))
(LIST (QUOTE VAR←↑)
VARNAME)
(LIST (QUOTE SIC)
(ADD1 BYTEOFFSET))
(QUOTE (GETBASEBYTE))
(LIST (QUOTE VAR)
VARNAME)
(QUOTE (LOGOR2]
(SETQ NBITSGOTTEN 16)
(SETQ SHIFTRIGHT (IDIFFERENCE 16 (IPLUS LBIT NBITS]
(* * generate code to right-align the desired bits)
(if (NOT (ZEROP SHIFTRIGHT))
then (TCONC OLT (LIST (QUOTE LRSH.N)
SHIFTRIGHT)))
(* * generate code to mask away excess bits on the left)
[if (NEQ NBITSGOTTEN NBITS)
then (LCONC OLT (LIST (LIST (QUOTE SIC)
(MASK.1'S 0 NBITS))
(QUOTE (LOGAND2]
(CAR OLT])
(D2T.EXPANDPUTBITS.N.FD
[LAMBDA (INSTR) (* jmh " 1-Apr-86 16:22")
(* * macro-expand a PUTBITS.N.FD instr in terms of byte accesses, shifts, and
masks, returning a list of instrs)
(* * have to return PTR like PUTBITS.N.FD, not BYTE like PUTBASEBYTE)
(LET ((BYTEOFFSET (ITIMES 2 (CADR INSTR)))
(LBIT (CADDR INSTR))
(NBITS (CADDDR INSTR))
(VARNAME1 (D2T.ADDLPVAR "D2T$temp1"))
(VARNAME3 (D2T.ADDLPVAR "D2T$temp3"))
(OLT (CONS))
1BYTE? LEFTSHIFT)
(* * generate comment = original instr)
(TCONC OLT (CONS (QUOTE *)
INSTR))
(* * generate code to save Value and pointer --
run-time stack is: pointer)
(LCONC OLT (LIST (LIST (QUOTE VAR←↑)
VARNAME1)
(LIST (QUOTE VAR←)
VARNAME3)))
(* * note whether we need one or two bytes of the target --
if one, note which -- set up LBIT to refer to a 16-bit entity right-justified
-- note how far we have to shift the source bits to align them with the target)
(if (IGEQ LBIT 8)
then (* need right byte)
(SETQ 1BYTE? T)
(add BYTEOFFSET 1)
elseif (ILEQ (IPLUS LBIT NBITS)
8)
then (* need left byte --
it will be right byte once we`ve
gotten it)
(SETQ 1BYTE? T)
(add LBIT 8)
else (* need two bytes)
(SETQ 1BYTE? NIL))
(SETQ LEFTSHIFT (IDIFFERENCE 16 (IPLUS LBIT NBITS)))
(* * generate code to get target, right-justified --
run-time stack will then be: pointer \ target)
[if 1BYTE?
then [LCONC OLT (LIST (QUOTE (COPY))
(LIST (QUOTE SIC)
BYTEOFFSET)
(QUOTE (GETBASEBYTE]
else (LET ((VARNAME2 (D2T.ADDLPVAR "D2T$temp2")))
(LCONC OLT (LIST (QUOTE (COPY))
(LIST (QUOTE SIC)
BYTEOFFSET)
(QUOTE (GETBASEBYTE))
(QUOTE (LLSH.N 8))
(LIST (QUOTE VAR←↑)
VARNAME2)
(QUOTE (COPY))
(LIST (QUOTE SIC)
(ADD1 BYTEOFFSET))
(QUOTE (GETBASEBYTE))
(LIST (QUOTE VAR)
VARNAME2)
(QUOTE (LOGOR2]
(* * generate code to clear the bits of the target where the source is to go)
[LCONC OLT (LIST (LIST (QUOTE SIC)
(MASK.0'S LEFTSHIFT NBITS))
(QUOTE (LOGAND2]
(* * generate code to push the source, to clear its excess left bits, and to
align it with the target -- run-time stack will then be: pointer \ target
<cleared> \ source <cleared and aligned>)
[LCONC OLT (LIST (LIST (QUOTE VAR)
VARNAME1)
(LIST (QUOTE SIC)
(MASK.1'S 0 NBITS))
(QUOTE (LOGAND2]
(if (NOT (ZEROP LEFTSHIFT))
then (TCONC OLT (LIST (QUOTE LLSH.N)
LEFTSHIFT)))
(* * generate code to merge source with target and save result --
run-time stack will then be: pointer)
(LCONC OLT (LIST (QUOTE (LOGOR2))
(LIST (QUOTE VAR←↑)
VARNAME1)))
(* * generate code to put target byte<s> back --
run-time stack will then be: pointer -- which is what the PUTBITS.N.FD opcode
leaves on the stack)
[if 1BYTE?
then (LCONC OLT (LIST (LIST (QUOTE SIC)
BYTEOFFSET)
(LIST (QUOTE VAR)
VARNAME1)
(QUOTE (PUTBASEBYTE))
(QUOTE (POP))
(LIST (QUOTE VAR)
VARNAME3)))
else (LCONC OLT (LIST (LIST (QUOTE SIC)
BYTEOFFSET)
(LIST (QUOTE VAR)
VARNAME1)
(QUOTE (LRSH.N 8))
(QUOTE (PUTBASEBYTE))
(QUOTE (POP))
(LIST (QUOTE VAR)
VARNAME3)
(LIST (QUOTE SIC)
(ADD1 BYTEOFFSET))
(LIST (QUOTE VAR)
VARNAME1)
(QUOTE (PUTBASEBYTE))
(QUOTE (POP))
(LIST (QUOTE VAR)
VARNAME3]
(CAR OLT])
)
(DEFINEQ
(D2T.ADDLPVAR
[LAMBDA (VAR)
(DECLARE (USEDFREE OUTEROLT PVARS)) (* jmh "27-Mar-86 14:34")
(* * if VAR isnt declared as a PVAR, declare it as a local pvar now --
return VAR)
[if (NOT (MEMBER VAR PVARS))
then (push PVARS VAR)
(* * locate that tail of OUTEROLT before the one whose CAR is CODE: --
also determine if there is a LOCAL: present)
(LET (TAIL LOCAL?)
(SETQ TAIL (CAR OUTEROLT))
(while (NEQ (CADR TAIL)
(QUOTE CODE:)) do (if (EQ (CAR TAIL)
(QUOTE LOCAL:))
then (SETQ LOCAL? T))
(SETQ TAIL (CDR TAIL)))
(* * insert declaration there)
(if (NOT LOCAL?)
then (LET [(X (BQUOTE (LOCAL:]
(RPLACD X (CDR TAIL))
(RPLACD TAIL X)
(SETQ TAIL X)))
(LET [(X (BQUOTE ((VAR:(\, VAR]
(RPLACD X (CDR TAIL))
(RPLACD TAIL X]
VAR])
)
(DEFINEQ
(D2T.PASSLABEL
[LAMBDA (LABEL) (* jmh " 4-Nov-85 17:39")
(* * process label encountered as instr --
-- project binding stack state onto label)
(DECLARE (USEDFREE BSTACK ERRS OLT)
(GLOBALVARS \D2T.LABEL2BSTACK \D2T.LABELSEEN?))
(TCONC OLT LABEL)
(if (GETHASH LABEL \D2T.LABELSEEN?)
then (push ERRS "label occurred before"))
(PUTHASH LABEL T \D2T.LABELSEEN?)
(if BSTACK
then (D2T.NOTELABEL LABEL)
else (SETQ BSTACK (GETHASH LABEL \D2T.LABEL2BSTACK)))
(D2T.ACCEPTERRORS])
(D2T.NOTELABEL
[LAMBDA (LABEL) (* jmh "29-Jan-86 12:14")
(DECLARE (GLOBALVARS \D2T.LABEL2BSTACK)
(USEDFREE BSTACK ERRS SMMP? SMU?))
(LET ((B (GETHASH LABEL \D2T.LABEL2BSTACK)))
(if (AND BSTACK (NEQ B (QUOTE ?)))
then (if (NULL B)
then (PUTHASH LABEL BSTACK \D2T.LABEL2BSTACK)
(SETQ SMMP? T)
elseif (NOT (EQUAL B BSTACK))
then (PUTHASH LABEL (QUOTE ?)
\D2T.LABEL2BSTACK)
(SETQ SMMP? T)
(SETQ SMU? T])
)
(DEFINEQ
(D2T.ACCEPTERRORS
[LAMBDA NIL (* jmh "23-Nov-85 16:00")
(* * if any errors in ERRSNOW, count them, append them onto last element of
OLT, and print the result -- if errors and last element of OLT isn't list,
TCONC pseudo-instr to OLT to append errors to)
(DECLARE (USEDFREE NERRS ERRS ERRFILE OLT))
(if ERRS
then (add NERRS (LENGTH ERRS))
[if (NLISTP (CADR OLT))
then (TCONC OLT (LIST "at" (CADR OLT]
[RPLACA (CDR OLT)
(APPEND (CADR OLT)
(CONS "*D2T errs*" (REVERSE ERRS]
(printout (OR ERRFILE T)
.PPV
(CADR OLT)
T)
(SETQ ERRS NIL])
(D2T.HELP
[LAMBDA (MSG1 MSG2) (* jmh "23-Nov-85 16:12")
(DECLARE (USEDFREE ERRFILE))
(if (NULL ERRFILE)
then (HELP MSG1 MSG2)
else (ASM.HELP MSG1 MSG2])
(D2T.WARN
[LAMBDA (MSG) (* jmh "31-Mar-86 15:36")
(* * print out a warning message labelled as coming from D2T)
(DECLARE (USEDFREE ERRFILE))
(printout (OR ERRFILE T)
"D2T warning-- " MSG T)
(RINGBELLS])
(D2T.SETSEQ
[LAMBDA (S1 S2) (* jmh "24-Oct-85 16:45")
(NOT (OR (LDIFFERENCE S1 S2)
(LDIFFERENCE S2 S1])
)
(PUTPROPS D2T COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1111 2262 (D2T 1121 . 2260)) (2263 7607 (D2T.PASSDECLS 2273 . 3846) (D2T.PASSFNDECL
3848 . 6005) (D2T.PASSVARDECLS 6007 . 7605)) (7608 18426 (D2T.PASSINSTRS 7618 . 10319) (
D2T.PASSINSTRSINNER 10321 . 12121) (D2T.CLUMP 12123 . 13350) (D2T.EXPAND 13352 . 14526) (
D2T.GENERICIZE 14528 . 18424)) (18427 22570 (D2T.EXPANDBIND 18437 . 19602) (D2T.EXPANDUNBIND 19604 .
20590) (D2T.EXPANDIVAR 20592 . 21199) (D2T.EXPANDIVAR← 21201 . 21904) (D2T.EXPANDFNX 21906 . 22568)) (
22571 34041 (D2T.EXPANDGETBASE.N 22581 . 23468) (D2T.EXPANDPUTBASE.N 23470 . 24791) (
D2T.EXPANDGETBITS.N.FD 24793 . 27982) (D2T.EXPANDPUTBITS.N.FD 27984 . 34039)) (34042 35408 (
D2T.ADDLPVAR 34052 . 35406)) (35409 36785 (D2T.PASSLABEL 35419 . 36077) (D2T.NOTELABEL 36079 . 36783))
(36786 38402 (D2T.ACCEPTERRORS 36796 . 37660) (D2T.HELP 37662 . 37905) (D2T.WARN 37907 . 38221) (
D2T.SETSEQ 38223 . 38400)))))
STOP