(FILECREATED "29-Mar-86 12:57:29" {ERIS}<TAMARIN>WORK>DT>T2D.;4 9833
changes to: (FNS T2D)
previous date: "27-Mar-86 16:05:00" {ERIS}<TAMARIN>WORK>DT>T2D.;3)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT T2DCOMS)
(RPAQQ T2DCOMS ((* * see associated doc: D2T.tedit)
(FNS T2D)
(FNS T2D.PASSDECLS)
(FNS T2D.UNBIND)
(FNS T2D.TAKEOUTFN7)
(FNS T2D.MAKESHIFTS)
(FNS T2D.ACCEPTERRORS T2D.HELP)))
(* * see associated doc: D2T.tedit)
(DEFINEQ
(T2D
[LAMBDA (IL ERRFILE) (* jmh
"29-Mar-86 09:17")
(* * IL is a LAP list -- error messages printed to <OR ERRFILE T> --
also see T2D.HELP)
(LET ((OLT (CONS))
(NERRS 0)
I ERRS IVARS)
(DECLARE (SPECVARS IL OLT NERRS ERRS ERRFILE IVARS))
(T2D.PASSDECLS)
(while (LISTP IL)
do (SETQ I (pop IL))
(if (NLISTP I)
then (TCONC OLT I)
elseif (EQ (QUOTE *)
(CAR I))
then (TCONC OLT I)
(if (EQ (CADR I)
(QUOTE forT2D:))
then (SELECTQ (CADDR I)
(BIND (TCONC OLT (QUOTE (BIND NIL NIL))))
(CHECKAPPLY* (TCONC OLT (QUOTE (CHECKAPPLY*))))
(FN7 (T2D.TAKEOUTFN7))
(push ERRS "unimpl * forT2D:")))
else (SELECTQ (CAR I)
(UNBIND (TCONC OLT (LIST (QUOTE UNBIND))))
(DUNBIND (TCONC OLT (LIST (QUOTE DUNBIND))))
('UNBIND (TCONC OLT (LIST (QUOTE *)
(QUOTE 'UNBIND)))
[while (AND (LISTP IL)
(EQ (CAR (CAR IL))
(QUOTE VAR←)))
do (T2D.UNBIND (CADR (pop IL]
(if (AND (LISTP IL)
(EQ (CAR (CAR IL))
(QUOTE VAR←↑)))
then (T2D.UNBIND (CADR (pop IL)))
else (push ERRS "'UNBIND sequence wrong")))
((VAR VAR← VAR←↑)
[if (MEMB (CADR I)
IVARS)
then (TCONC OLT (CONS (SELECTQ (CAR I)
(VAR (QUOTE IVAR))
(VAR← (QUOTE IVAR←))
(VAR←↑ (QUOTE IVAR←↑))
(T2D.HELP 1))
(CDR I)))
else (TCONC OLT (CONS (SELECTQ (CAR I)
(VAR (QUOTE PVAR))
(VAR← (QUOTE PVAR←))
(VAR←↑ (QUOTE PVAR←↑))
(T2D.HELP 2))
(CDR I])
((ICONST PCONST)
(TCONC OLT (CONS (QUOTE GCONST)
(CDR I))))
(LLSH.N (LCONC OLT (T2D.MAKESHIFTS (QUOTE LLSH1)
(QUOTE LLSH8)
(CADR I))))
(LRSH.N (LCONC OLT (T2D.MAKESHIFTS (QUOTE LRSH1)
(QUOTE LRSH8)
(CADR I))))
(TCONC OLT I)))
(T2D.ACCEPTERRORS))
(CONS NERRS (CAR OLT])
)
(DEFINEQ
(T2D.PASSDECLS
[LAMBDA NIL
(DECLARE (USEDFREE IL OLT ERRS IVARS)) (* jmh "28-Jan-86 11:23")
(LET (I)
(if [AND (LISTP IL)
(LISTP (SETQ I (CAR IL)))
(MEMB (CAR I)
(QUOTE (LAMBDA: NLAMBDA:]
then (if (AND (LISTP (CDR I))
(LISTP (CDDR I)))
then (SETQ IVARS (CADDR I))
(if [AND (NEQ IVARS NIL)
(NEQ IVARS T)
(OR (NLISTP IVARS)
(AND (EQ 2 (LENGTH IVARS))
(OR (LITATOM (CAR IVARS))
(STRINGP (CAR IVARS)))
(NUMBERP (CADR IVARS]
then (SETQ IVARS (LIST IVARS)))
(TCONC OLT (pop IL))
else (TCONC OLT (pop IL))
(push ERRS "bad N/LAMBDA: decl"))
else (TCONC OLT (LIST "at beginning"))
(push ERRS "no N/Lambda: decl"))
(T2D.ACCEPTERRORS)
(while (LISTP IL) eachtime (SETQ I (pop IL)) repeatuntil (EQ I (QUOTE CODE:))
do (if [AND (LISTP I)
(MEMB (CAR I)
(QUOTE (VAR: VARS:]
then (if (NLISTP (CDR I))
then (TCONC OLT I)
(push ERRS "ill-formed VARS: decl")
elseif (NULL (LDIFFERENCE (CDR I)
IVARS))
then (TCONC OLT (CONS (QUOTE IVARS:)
(CDR I)))
elseif (NULL (INTERSECTION (CDR I)
IVARS))
then (TCONC OLT (CONS (QUOTE PVARS:)
(CDR I)))
else (TCONC OLT I)
(push ERRS "mixed Ivars and Pvars"))
elseif (EQUAL I (QUOTE (* forT2D: arglistIsPvar)))
then (SETQ IVARS)
(TCONC OLT I)
else (TCONC OLT I))
(T2D.ACCEPTERRORS))
(if (NLISTP IL)
then (TCONC OLT (LIST "at end"))
(push ERRS "no fn body")
(T2D.ACCEPTERRORS])
)
(DEFINEQ
(T2D.UNBIND
[LAMBDA (V)
(DECLARE (USEDFREE OLT)) (* jmh "24-Oct-85 15:43")
(TCONC OLT (LIST (QUOTE BIND)
NIL
(LIST V)))
(TCONC OLT (LIST (QUOTE DUNBIND])
)
(DEFINEQ
(T2D.TAKEOUTFN7
[LAMBDA NIL
(DECLARE (USEDFREE IL OLT ERRS)) (* jmh
" 9-Dec-85 11:45")
(LET (I N FN)
(if [NOT (AND (ILEQ 3 (LENGTH IL))
(LISTP (SETQ I (CAR IL)))
(EQ 2 (LENGTH I))
(EQ (QUOTE SIC)
(CAR I))
(NUMBERP (SETQ N (CADR I)))
(ILEQ 1 N)
(EQUAL (QUOTE (FN 1 \VectorizeN))
(CADR IL))
(LISTP (SETQ I (CADDR IL)))
(EQ 3 (LENGTH I))
(EQ (QUOTE FN)
(CAR I))
(EQ 7 (CADR I))
(LITATOM (SETQ FN (CADDR I]
then (push ERRS "following [3] instrs not right for deFN7ization")
else (SETQ IL (CDDDR IL))
(TCONC OLT (LIST (QUOTE FN)
(IPLUS N 6)
FN])
)
(DEFINEQ
(T2D.MAKESHIFTS
[LAMBDA (SH1INSTR SH8INSTR NSHIFTS) (* jmh
"27-Mar-86 13:32")
(* * return a list of shift instrs, the CARs of which are from the two
instrs given us as args, to shift enough times)
(LET ((OLT (CONS)))
(while (IGEQ NSHIFTS 8) do (TCONC OLT (LIST SH8INSTR))
(add NSHIFTS -8))
(while (IGEQ NSHIFTS 1) do (TCONC OLT (LIST SH1INSTR))
(add NSHIFTS -1))
(CAR OLT])
)
(DEFINEQ
(T2D.ACCEPTERRORS
[LAMBDA NIL (* jmh "23-Nov-85 15:53")
(* * if any errors in ERRS 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 "*T2D errors*" (REVERSE ERRS]
(printout (OR ERRFILE T)
.PPV
(CADR OLT)
T)
(SETQ ERRS NIL])
(T2D.HELP
[LAMBDA (MSG1 MSG2) (* jmh "23-Nov-85 16:16")
(DECLARE (USEDFREE ERRFILE))
(if (NULL ERRFILE)
then (HELP MSG1 MSG2)
else (ASM.HELP MSG1 MSG2])
)
(PUTPROPS T2D COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (600 4538 (T2D 610 . 4536)) (4539 6619 (T2D.PASSDECLS 4549 . 6617)) (6620 6879 (
T2D.UNBIND 6630 . 6877)) (6880 8040 (T2D.TAKEOUTFN7 6890 . 8038)) (8041 8723 (T2D.MAKESHIFTS 8051 .
8721)) (8724 9754 (T2D.ACCEPTERRORS 8734 . 9502) (T2D.HELP 9504 . 9752)))))
STOP