(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "10-Nov-87 16:18:38" {PHYLUM}<CTAMARIN>EMULATOR>MICROASSEMBLER.;47 45952
changes to%: (FNS NoteOpcode)
previous date%: " 3-Nov-87 18:35:58" {PHYLUM}<CTAMARIN>EMULATOR>MICROASSEMBLER.;45)
(* "
Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT MICROASSEMBLERCOMS)
(RPAQQ MICROASSEMBLERCOMS
((FNS AUCode AssembleUCode SetAddrField SwapAB CheckLabel CheckUndefinedLabels CollectLine
FixEltLst NoteOpcode PutTamProps ParseElt ParseLine ParseLine2 PutLabel MakeOpList
ReformatOpPla ShowFields PutAssocHash GetAssocHash ShowUCodeAlloc FindFreeSide FixLine)
(* * Misc)
(UGLYVARS lineReadTable)
(VARS PreCondList)))
(DEFINEQ
(AUCode
[LAMBDA (local) (* ; "Edited 3-Apr-87 16:44 by rtk")
(SETQ local (if (EQ local T)
then '{DSK}TUCODE
elseif local
then local
else '{Phylum}<CTamarin>Emulator>TUCode))
(CLOSEF? local)
(AssembleUCode local)
(CLOSEF? local) (* SETQ undefinedlist
(for i in labellist when
(NOT (FMEMB i startlist)) collect i))
(* SETQ LCFIL NIL)
(* SETQ STRF T)
NIL])
(AssembleUCode
[LAMBDA (file) (* ; "Edited 3-Apr-87 15:54 by rtk")
(PROG (fl mi line fixLst opNbr)
(SETQ OpcodeMode NIL)
(SETQ defaultlist NIL)
(SETQ startlist NIL)
(SETQ labellist NIL)
(SETQ fl (INPUT (INFILE file)))
(SETQ OpCodeList NIL)
(SETQ opArray (ARRAY 256 'POINTER NIL 0))
(SETQ UCodeRomA (ARRAY 257 'POINTER NIL 0))
(SETQ UCodeRomB (ARRAY 257 'POINTER NIL 0))
(SETQ LabelList NIL)
(PutLabel 'Done 512)
(PutLabel '*Done 768)
(SETQ AtomList NIL)
(for i in PreCondList do (PUTPROP i 'PreCondStart 0))
(SETQ EltLst NIL)
(SETQ OpPlaList NIL)
(SETQ OpPlaTerms NIL)
(PRINTOUT T "Scanning uCode" T)
L1 (SETQ line (CollectLine fl))
(SETQ mi (ParseLine (FixLine line)))
(if (EQ T mi)
then (PRINTOUT T "Scanning Opcode Entry Points" T)
(GO L2))
(SETQ AtomList (LDIFFERENCE AtomList AtomList))
(BLOCK)
(GO L1)
L2 (SETQ line (CollectLine fl))
(SETQ mi (ParseLine2 line))
(if (EQ T mi)
then (GO L4))
(GO L2)
L4 (CheckUndefinedLabels)
(PROG [[AsideLeft (for i from 0 to 255 count (NOT (ELT UCodeRomA i]
(BsideLeft (for i from 0 to 255 count (NOT (ELT UCodeRomB i]
(PRINTOUT T AsideLeft " Microcode Locations left on A side" T)
(PRINTOUT T BsideLeft " Microcode Locations left on B side" T)
(PRINTOUT T (PLUS AsideLeft BsideLeft)
" Total Microcode Locations Left out of "
(TIMES 2 (ARRAYSIZE UCodeRomA))
T))
(CLOSEF fl])
(SetAddrField
[LAMBDA (mi field addr) (* ; "Edited 28-Sep-87 11:55 by Krivacic")
(PROG [(Adef (NUMBERP (fetch (MI NextInstA) of mi)))
(Bdef (NUMBERP (fetch (MI NextInstB) of mi)))
(Aok (EQ 0 (LOGAND addr 256)))
[Bok (OR (EQ 256 (LOGAND addr 256))
(TF (fetch (MI ForceDone) of mi]
(Addrok (AND (EQ field 'Addr)
(OR (AND (NOT (fetch (MI RomSide) of mi))
(replace (MI RomSide) of mi with (RSH addr 8)))
(EQ (fetch (MI RomSide) of mi)
(RSH addr 8]
(SELECTQ field
(NextInstA (if (NOT (OR Aok Bdef))
then (SwapAB mi (fetch (MI NextInstB) of mi)
'NextInstA)
(SETQ field 'NextInstB)))
(NextInstB (if (NOT (OR Bok Adef))
then (SwapAB mi (fetch (MI NextInstA) of mi)
'NextInstB)
(SETQ field 'NextInstA)))
(Addr T)
(BREAK1 NIL T (Illegal field type)))
(if (SELECTQ field
(NextInstA Aok)
(NextInstB Bok)
(Addr Addrok)
NIL)
then (SETQ addr (LOGOR (LOGAND addr 255)
(RSH (LOGAND addr 512)
1)))
(RECORDACCESS field mi NIL 'REPLACE addr)
(if (EQ field 'Addr)
then (if (EQ (fetch (MI RomSide) of mi)
0)
then (SETA UCodeRomA addr mi)
else (SETA UCodeRomB addr mi))
(if (EQ (fetch (MI Label) of mi)
'Reset)
then (SETQ ResetAddr addr))
(if (EQ (fetch (MI Label) of mi)
'RefCount)
then (SETQ RefCountAddr addr))
(if (EQ (fetch (MI Label) of mi)
'StackRefill)
then (SETQ StackRefillAddr addr))
(if (EQ (fetch (MI Label) of mi)
'Noop)
then (SETQ NoopAddr addr)))
else (PRINTOUT T "Illegal address / jump " (fetch (MI Ucode) of mi)
T)
(PRINTOUT T "Field: " field " = " addr T])
(SwapAB
[LAMBDA (mi label repfield) (* ; "Edited 27-May-87 16:30 by rtk")
(replace (MI InvertCCode) of mi with (LOGXOR (fetch (MI InvertCCode) of mi)
1))
(PROG ((temp (fetch (MI NextInstA) of mi)))
(replace (MI NextInstA) of mi with (fetch (MI NextInstB) of mi))
(replace (MI NextInstB) of mi with temp))
(if label
then (PutAssocHash label (for i in (GetAssocHash label)
collect (if (AND (EQ (CADR i)
mi)
(NEQ 'Addr (CAR i)))
then (LIST repfield mi)
else i])
(CheckLabel
[LAMBDA (datum field label) (* edited%: "29-Oct-86 12:44")
(PROG (a)
(if (NUMBERP label)
then (SetAddrField datum field label)
(RETURN))
(if (NOT label)
then (HELP))
(SETQ a (GetAssocHash label))
(if (NUMBERP a)
then (SetAddrField datum field a)
else (SELECTQ field
(NextInstA (replace (MI NextInstA) of datum with label))
(NextInstB (replace (MI NextInstB) of datum with label))
NIL)
(PutAssocHash label (CONS (LIST field datum)
a])
(CheckUndefinedLabels
[LAMBDA NIL (* rtk "25-Nov-86 13:01")
(PRINTOUT T "Allocating uCode" T)
(PutLabel 'DoneB 512 0)
(for mode in '(aside bside labels rest)
do
(PROG (newlabellist newentry)
(for i in (SORT LabelList T)
do
[PROG (datum nonlabeled (val (CDR i)))
[AND (LISTP val)
(SETQ datum (CADR (for v in val thereis (EQ 'Addr (CAR v]
(SETQ newentry i)
(if datum
then
(SETQ nonlabeled (EQUAL (SUBSTRING (fetch (MI Label) of datum)
1 3)
"LAB"))
[if (SELECTQ mode
(aside (EQ 0 (fetch (MI RomSide) of datum)))
(bside (EQ 1 (fetch (MI RomSide) of datum)))
(labels (NOT nonlabeled))
(rest T)
NIL)
then
(PROG (addr Baddr Aaddr (key (CAR i)))
(if (LISTP val)
then (if (NOT datum)
then (PRINTOUT T "Undefined label - " key T))
[SETQ Aaddr (for i from 0 to 255
thereis (NOT (ELT UCodeRomA i]
(SETQ Baddr (LOGOR (for i from 0 to 255
thereis (NOT (ELT UCodeRomB i)))
256))
(SETQ addr
(SELECTQ (fetch (MI RomSide) of datum)
(0 Aaddr)
(1 Baddr)
(OR (FindFreeSide (AND nonlabeled
(EQ mode 'rest))
val Aaddr Baddr)
Baddr Aaddr)))
(SETQ newentry (CONS (fetch (MI Label) of datum)
addr))
(for v in val do (SetAddrField (CADR v)
(CAR v)
addr]
else (if (AND (LISTP (CDR i))
(EQ mode 'rest))
then (PRINTOUT T "Undefined Label: " (CAR i)
T]
(SETQ newlabellist (CONS newentry newlabellist)))
(SETQ LabelList newlabellist])
(CollectLine
[LAMBDA (file) (* ; "Edited 27-Apr-87 10:34 by rtk")
(PROG (c foundit firstchar stopchar result)
(until (OR (EOFP file)
foundit) do (SETQ foundit T)
(SETQ firstchar T)
(SETQ stopchar ';)
(SETQ result (until [OR (EOFP file)
(EQ stopchar (SETQ c (READ file
lineReadTable]
collect (if (AND firstchar (EQ c '{))
then (SETQ stopchar '})
(SETQ foundit NIL))
(SETQ firstchar NIL)
c)))
(RETURN result])
(FixEltLst
[LAMBDA NIL (* agb%: " 3-Jan-86 17:03")
(PROG (lastlst reslst last)
(SETQ NEltLst (SORT (APPEND EltLst)
T))
(for i in NEltLst when [NOT (MEMB (CAR i)
'(nextinsta nextinstb start opname label opnbr]
do [if (EQ last (CAR i))
then (if (NOT (MEMB (CADR i)
(CDR lastlst)))
then (NCONC1 lastlst (CADR i)))
else (SETQ reslst (NCONC1 reslst (SETQ lastlst (LIST (CAR i)
(CADR i]
(SETQ last (CAR i)))
(for i in reslst do (SORT (CDR i)))
[SORT reslst (FUNCTION (LAMBDA (x y)
(PROG (p1 p2)
(SETQ p1 (CADR (ASSOC (CAR x)
FieldOrder)))
(SETQ p2 (CADR (ASSOC (CAR y)
FieldOrder)))
(RETURN (COND
((AND p1 p2)
(ILESSP p1 p2))
(p1 p1)
(p2 p2)
(T (ALPHORDER (CAR x)
(CAR y]
(RETURN reslst])
(NoteOpcode
[LAMBDA (name addr oplength) (* ; "Edited 10-Nov-87 10:05 by Krivacic")
(LET* ((posK (STRPOS 'K name))
(posk (STRPOS 'k name)))
(if (FMEMB name '(VARK VARK← VARK←↑
TJUMPK↑ FJUMPK↑ JUMPK))
then (for i from 0 to 7
do (PutTamProps (PACK (if (SUBSTRING name (ADD1 posK))
then (LIST (SUBSTRING name 1 (SUB1 posK))
i
(SUBSTRING name (ADD1 posK)))
else (LIST (SUBSTRING name 1 (SUB1 posK))
i)))
(PLUS addr i)
NIL oplength)))
(if (FMEMB name '(VARk VARk← VARk←↑
TJUMPk↑ FJUMPk↑ JUMPKk))
then (for i from 0 to 7
do (PutTamProps [PACK (if (SUBSTRING name (ADD1 posk))
then (LIST (SUBSTRING name 1 (SUB1 posk))
(PLUS 8 i)
(SUBSTRING name (ADD1 posk)))
else (LIST (SUBSTRING name 1 (SUB1 posk))
(PLUS 8 i]
(PLUS addr i)
NIL oplength)))
(PutTamProps name addr T oplength])
(PutTamProps
[LAMBDA (name addr putoparray oplength) (* ; "Edited 2-Nov-87 12:03 by Krivacic")
(DECLARE (GLOBALVARS opArray OpCodeList UCodeRomA))
(PUTPROP name 'TamarinOp addr)
(SETQ OpCodeList (CONS (LIST name addr)
OpCodeList))
(PUTPROP name 'TamarinOpLength oplength)
(if putoparray
then (if (ELT opArray addr)
then (printout T "Opcode already defined - nbr=" addr T))
(SETA opArray addr name])
(ParseElt
[LAMBDA (elt1 prop) (* ; "Edited 24-Apr-87 17:19 by rtk")
(PROG (fval val type elt pos)
[if (EQ elt1 '*)
then (RETURN '(Comment]
(SETQ pos (STRPOS "←" elt1))
(if pos
then [SETQ val (MKATOM (SUBSTRING elt1 (ADD1 pos]
(SETQ AtomList (CONS val AtomList))
[SETQ elt (MKATOM (SUBSTRING elt1 1 (SUB1 pos]
(SETQ AtomList (CONS elt AtomList))
else (SETQ elt elt1)
(SETQ AtomList (CONS elt AtomList))
(SETQ val T))
(SETQ lcelt (L-CASE elt))
(SETQ type (GETPROP lcelt prop))
(if (AND (NOT (FMEMB lcelt defaultlist))
(LISTP type)
(LISTP (CAR type))
(EQ (CADAR type)
0))
then (SETQ EltLst (CONS (LIST lcelt (CAAR type))
EltLst))
(SETQ defaultlist (CONS lcelt defaultlist))
(if (NEQ (CAAR type)
val)
then (SETQ EltLst (CONS (LIST lcelt val)
EltLst)))
else (SETQ EltLst (CONS (LIST lcelt val)
EltLst)))
[if (EQ type 'val)
then [if (NUMBERP val)
then (SETQ fval val)
else (SETQ fval (GETPROP val 'TamConst]
elseif (AND (EQ type 'atom)
(LITATOM val))
then (SETQ fval val)
elseif (LISTP type)
then (SETQ fval (CADR (FASSOC val type)))
(if [AND (NOT hadCcInvert)
(NOT fval)
(EQUAL (SUBSTRING val 1 1)
"~")
(OR (EQ elt 'DpCCode)
(EQ elt 'MuxCCode)
(EQ elt 'EuCCode)
(EQ elt 'MemCCode]
then (SETQ hadCcInvert T)
(SETQ fval (CADR (FASSOC (MKATOM (SUBSTRING val 2))
type))) (* ;
"if fval then (SETQ fval (LOGXOR fval (SELECTQ elt (DPCCode 64) (MuxCCode 16) (ResutlCCode 16) 0)))")
)
(* ;; "if (AND (NOT fval) NIL (OR (EQ elt (QUOTE Raddr)) (EQ elt (QUOTE Waddr))) (SETQ fval (FASSOC val (GETPROP (QUOTE k) (QUOTE uField))))) then (SETQ fval (LOGOR (LOGAND (CADR fval) 31) 32))")
(if (AND (NOT fval)
(NUMBERP val))
then (SETQ fval val)
elseif (AND (EQ prop 'uField)
(LISTP fval))
then (SETQ fval (EVAL fval)))
elseif (AND (EQ type 'Flag)
(EQ val T))
then (SETQ fval 1)
elseif (AND (EQ type 'Label)
(OR (LITATOM val)
(NUMBERP val)))
then (SETQ fval val)
else (SETQ fval (CADR (FASSOC elt (GETPROP 'precond 'uField2]
(if (NOT fval)
then (PRINT line)
(PRIN1 "Unknown field - ")
(PRIN1 elt)
(PRIN1 "←")
(PRINT val)
(RETURN NIL))
(RETURN (LIST elt fval val])
(ParseLine
[LAMBDA (line) (* ; "Edited 3-Nov-87 10:34 by Krivacic")
(PROG (hadEUop hadRaddr hadRD1addr hadRD2addr hadWrite hadTag hadWCycle hadDswap hadCxt hadAlt mi
addr res val label nextinsta nextinstb sideset hadCcInvert hadMuxBus muxset hadcas)
(DECLARE (CL:SPECIAL hadEUop hadRaddr hadRD1addr hadRD2addr hadMuxBus hadWrite hadTag
hadWCycle hadDswap hadCxt hadAlt mi addr res val label nextinsta nextinstb
sideset hadCcInvert muxset))
(if (EQ (CAR line)
'End)
then (RETURN T))
(if (EQ (CAR line)
'*)
then (RETURN NIL))
(SETQ mi (create MI))
(replace (MI Ucode) of mi with line)
(replace (MI MuxBus) of mi with (UProp 'K 'muxbus))
(replace (MI Raddr) of mi with (UProp 'K 'raddr))
(replace (MI RD1addr) of mi with (UProp 0 'rd1addr))
(replace (MI RD2addr) of mi with (UProp 0 'rd2addr))
(replace (MI WriteT) of mi with 1)
(replace (MI WriteF) of mi with 1)
(replace (MI NextInstA) of mi with NIL)
(replace (MI NextInstB) of mi with NIL)
(replace (MI OpLength) of mi with 7)
(replace (MI EUop) of mi with (UProp 'D1 'euop))
(replace (MI NewTos) of mi with (UProp 'Tos 'newtos))
(replace (MI NewArg) of mi with (UProp 'Arg 'newarg))
(replace (MI NewArg2) of mi with (UProp 'Arg2 'newarg2))
(replace (MI K2) of mi with 1)
(for elt in line
do (SETQ res (ParseElt elt 'uField))
(SETQ val (CADR res))
(SELECTQ (CAR res)
(Label (SETQ label val))
(OpLength (replace (MI OpLength) of mi with val))
(EUop (SETQ hadEUop (GREATERP val 2))
(replace (MI EUop) of mi with val))
(Tag (SETQ hadTag T)
(replace (MI Tag) of mi with val))
(MemOp (replace (MI MemOp) of mi with val)
[SETQ hadcas (EQ val (UProp 'Cas 'memop])
(MemOffset (replace (MI MemOffset) of mi with val))
(PcSrc (replace (MI PcSrc) of mi with val))
(PhysAddrSrc (replace (MI PhysAddrSrc) of mi with val))
(MemLatchSrc (replace (MI MemLatchSrc) of mi with val))
(Raddr (SETQ hadRaddr T)
(replace (MI Raddr) of mi with val)
[if (NOT hadRD1addr)
then (replace (MI RD1addr) of mi with (UProp 'Raddr 'rd1addr]
[if (NOT hadRD2addr)
then (replace (MI RD2addr) of mi with (UProp 'Raddr-1 'rd2addr])
(Waddr (SETQ hadWrite T)
(replace (MI Waddr) of mi with val))
(RD1addr (SETQ hadRD1addr T)
(replace (MI RD1addr) of mi with val))
(RD2addr (SETQ hadRD2addr (CADDR res))
(replace (MI RD2addr) of mi with val))
(W2addr (SETQ hadWrite T)
(replace (MI W2addr) of mi with val))
(RCxt (replace (MI RCxt) of mi with 1)
(SETQ hadCxt T))
(WCxt (replace (MI WCxt) of mi with 1)
(SETQ hadCxt T))
(NewTopCxt (replace (MI NewTopCxt) of mi with 1)
(SETQ hadCxt T))
(NewBotCxt (replace (MI NewBotCxt) of mi with 1)
(SETQ hadCxt T))
(AltCxt (replace (MI AltCxt) of mi with val)
(SETQ hadAlt T))
(Dswap (SETQ hadDswap T)
(replace (MI Dswap) of mi with 1))
(NewArg (replace (MI NewArg) of mi with val))
(NewArg2 (replace (MI NewArg2) of mi with val))
(NewTos (replace (MI NewTos) of mi with val))
(MuxBus (SETQ hadMuxBus T)
(replace (MI MuxBus) of mi with val)
(if muxset
then (PRINT line)
(PRINTOUT T "Cannot set MuxBus more than once" T))
(SETQ muxset T))
(OpMask (replace (MI OpMask) of mi with val))
(K (replace (MI K) of mi with val))
(K2 (replace (MI K2) of mi with val))
(DpCCode (replace (MI DpCCode) of mi with val))
(MuxCCode (replace (MI MuxCCode) of mi with val))
(EuCCode (replace (MI EuCCode) of mi with val))
(MemCCode (replace (MI MemCCode) of mi with val))
(WriteT (replace (MI WriteF) of mi with 0))
(WriteF (replace (MI WriteT) of mi with 0))
(Misc (replace (MI Misc) of mi with val))
(JumpT (SETQ nextinsta val)
(if (EQ val 'Done)
then (if (TF (fetch (MI Done) of mi))
then (replace (MI ForceDone) of mi with 1))
(replace (MI Done) of mi with 1))
(if (NOT (FMEMB val startlist))
then (SETQ startlist (NCONC1 startlist val))))
(JumpF (SETQ nextinstb val)
(if (EQ val 'Done)
then (if (TF (fetch (MI Done) of mi))
then (replace (MI ForceDone) of mi with 1))
(replace (MI Done) of mi with 1))
(if (NOT (FMEMB val startlist))
then (SETQ startlist (NCONC1 startlist val))))
(ForceDone (replace (MI Done) of mi with 1)
(replace (MI ForceDone) of mi with 1)
(SETQ nextinsta 'Done)
(SETQ nextinstb 'Done))
(Aside (if sideset
then (PRINTOUT T "Cannot place on both sides of Rom " line T))
(replace (MI RomSide) of mi with 0)
(SETQ sideset T))
(Bside (if sideset
then (PRINTOUT T "Cannot place on both sides of Rom " line T))
(replace (MI RomSide) of mi with 1)
(SETQ sideset T))
(LatchFetchPc (replace (MI LatchFetchPc) of mi with 1))
(LatchPc (replace (MI LatchPc) of mi with 1))
(WriteOctal (replace (MI WriteOctal) of mi with 1))
(ForceDone (replace (MI ForceDone) of mi with 1))
(WriteTags (replace (MI WriteTags) of mi with 1)
(SETQ hadWCycle T))
(WriteData (replace (MI WriteData) of mi with 1)
(SETQ hadWCycle T))
(ByteAddr (replace (MI ByteAddr) of mi with 1))
(SetFlags (replace (MI SetFlags) of mi with 1))
(ClrFlags (replace (MI ClrFlags) of mi with 1))
(Comment (GO L1))
(NIL NIL)
(HELP)))
L1 (if [AND hadcas (NOT hadWCycle)
(GREATERP (fetch (MI EUop) of mi)
(UProp 'XTag 'euop]
then (PRINT line)
(PRINTOUT T "Missing Memory EUop" T))
(if hadCcInvert
then (replace (MI InvertCCode) of mi with 1)
(if [NOT (OR (EQ 0 (LOGOR (fetch (MI DpCCode) of mi)
(fetch (MI MuxCCode) of mi)
(fetch (MI EuCCode) of mi)))
(EQ 0 (LOGOR (fetch (MI DpCCode) of mi)
(fetch (MI MuxCCode) of mi)
(fetch (MI MemCCode) of mi)))
(EQ 0 (LOGOR (fetch (MI DpCCode) of mi)
(fetch (MI EuCCode) of mi)
(fetch (MI MemCCode) of mi)))
(EQ 0 (LOGOR (fetch (MI MuxCCode) of mi)
(fetch (MI EuCCode) of mi)
(fetch (MI MemCCode) of mi]
then (PRINT line)
(PRINTOUT T "Cannot Negate more than one condition" T)))
[if (NOT label)
then (SETQ label (GENSYM 'LAB]
(replace (MI Label) of mi with label)
(CheckLabel mi 'Addr label)
(for i in fixLst do (CheckLabel (CAR i)
(CADR i)
label))
(SETQ fixLst NIL)
(if (NOT nextinsta)
then [SETQ fixLst (LIST (LIST mi 'NextInstA]
else (CheckLabel mi 'NextInstA (if (EQ nextinsta 'Rpt)
then label
else nextinsta)))
(if (NOT nextinstb)
then (if (NEQ 0 (LOGOR (fetch (MI DpCCode) of mi)
(fetch (MI MuxCCode) of mi)
(fetch (MI EuCCode) of mi)
(fetch (MI MemCCode) of mi)))
then (SETQ fixLst (CONS (LIST mi 'NextInstB)
fixLst)))
else (if (EQ nextinstb 'Done)
then (SETQ nextinstb 'DoneB))
(CheckLabel mi 'NextInstB (if (EQ nextinstb 'Rpt)
then label
else nextinstb)))
(if (AND hadEUop hadWrite (NOT hadTag))
then (PRINT line)
(PRINTOUT T "Missing Tag Field for EUop " T))
(if (AND hadWCycle (NOT hadDswap)
(NOT (OR hadRaddr hadRD2addr)))
then (PRINT line)
(PRINTOUT T "Missing field for Write Cycle" T))
(if (AND hadCxt (NOT hadAlt))
then (PRINT line)
(PRINTOUT T "Missing AltCxt Field " T)) (* if (AND hadRaddr hadRD1addr
(AND hadRD2addr (NEQ hadRD2addr
(QUOTE Raddr-1)))) then
(PRINT line) (PRINTOUT T
"Conflicting read addresses" T))
(RETURN (LIST addr mi])
(ParseLine2
[LAMBDA (line) (* ; "Edited 3-Nov-87 09:52 by Krivacic")
(PROG (res name val)
(if (EQ (CAR line)
'End)
then (RETURN T))
[SELECTQ (CAR line)
(UniStart (for elt in line
do (SETQ res (ParseElt elt 'uField2))
(SETQ val (CADR res))
(SELECTQ (CAR res)
(OpNbr (if (OR (NOT opNbr)
(GEQ val opNbr))
then (SETQ opNbr val)
else (PRINTOUT T "Cannot Set OpNumber backwards " val T)))
(UniStart (SETQ OpcodeMode 'UniStart))
(PRINTOUT T "Unknown Field - " res T))))
(MultiStart (for elt in line
do (SETQ res (ParseElt elt 'uField2))
(SETQ val (CADR res))
(SELECTQ (CAR res)
(OpNbr (if (OR (NOT opNbr)
(GEQ val opNbr))
then (SETQ opNbr val)
else (PRINTOUT T "Cannot Set OpNumber backwards " val T)
))
(MultiStart (SETQ OpcodeMode 'MultiStart))
(PRINTOUT T "Unknown Field - " res T))))
(PROG (name name-list had-start oplength (opcount 0))
(for elt in line
do (SETQ res (ParseElt elt 'uField2))
(SETQ val (CADR res))
(SELECTQ (CAR res)
(OpNbr (if (OR (NOT opNbr)
(GEQ val opNbr))
then (SETQ opNbr val)
else (PRINTOUT T "Cannot Set OpNumber backwards " val T)))
(OpName (if (AND name (NEQ OpcodeMode 'MultiStart))
then (PRINTOUT T "Inncorect number of args - " line T)
else (SETQ name val)
(SETQ name-list (CONS name name-list))
(SETQ opcount (ADD1 opcount))))
(Start [if had-start
then (PRINTOUT T "Inncorect number of args - " line T)
else (SETQ had-start T)
(SETQ oplength (PutLabel val opNbr 0 T name))
(for name in name-list as opcode
from (PLUS opNbr (SUB1 opcount)) by -1
do (NoteOpcode name opcode oplength))
(SETQ opNbr (PLUS opNbr (if (EQ OpcodeMode 'MultiStart)
then 8
else 1])
(PRINTOUT T "Unknown Field - " res T]
(RETURN opNbr])
(PutLabel
[LAMBDA (label val side needoplength opcodename) (* ; "Edited 2-Nov-87 12:16 by Krivacic")
(PROG (a flg oplength)
(SETQ a (GetAssocHash label))
(if (NUMBERP a)
then (PRINTOUT T "Multiply defined label - " label T)
(RETURN))
(if (LISTP a)
then (for i in a when (EQ 'Addr (CAR i))
do (SETQ flg T)
(if side
then (if (AND (fetch (MI RomSide) of (CADR i))
(NEQ (fetch (MI RomSide) of (CADR i))
side))
then (PRINTOUT T "Cannot move microinstruction to a new side: "
T)
(PRINTOUT T (fetch (MI Ucode) of (CADR i))
T)
else (replace (MI RomSide) of (CADR i) with side)))
(SETQ oplength (fetch (MI OpLength) of (CADR i)))
(if (AND needoplength (EQ 7 oplength))
then (PRINTOUT T "Oplength Field missing for Opcode: "
(fetch (MI Label) of (CADR i))
" @ " val T))
(if (OR (AND (EQ 0 (fetch (MI RomSide) of (CADR i)))
(ELT UCodeRomA val))
(AND (EQ 1 (fetch (MI RomSide) of (CADR i)))
(ELT UCodeRomB val)))
then (PRINTOUT T "Multiply defined ucode location - " val " " label T)))
(for i in a do (SetAddrField (CADR i)
(CAR i)
val)))
(if (NOT flg)
then (if (EQ label 'Done)
then (SETA UCodeRomA 256 T)
elseif (OR (EQ label 'DoneB)
(EQ label '*Done))
then (SETA UCodeRomB 256 T)
else (PRINTOUT T "Undefined ucode location - " label T)))
(PutAssocHash label val)
(RETURN oplength])
(MakeOpList
[LAMBDA (FILE) (* rtk "12-May-86 15:58")
(SETQ FILE (OPENFILE FILE 'OUTPUT))
(LINELENGTH (ITIMES 8 15)
FILE)
(printout FILE "Tamarin opcode assignments, generated " (DATE)
T T)
(bind op tab from 0 for i to 255 do (SETQ op (ELT OpPlaArray i))
(SETQ tab (ITIMES 20 (IREMAINDER i 4)))
(printout FILE .TAB tab
(if (OR (NOT op)
(EQ 'Undefined (CAR op)))
then ""
else (CAR op))
.TAB
(IPLUS 16 tab)
|.I3.8| i))
(CLOSEF FILE])
(ReformatOpPla
[LAMBDA (opd) (* rtk "22-Apr-86 12:38")
(LIST (fetch (OpD Val) of opd)
(fetch (OpD Mask) of opd)
(ConcatBitsVal (CADR OpPlaSpec)
(LIST (fetch (OpD Length) of opd)
(fetch (OpD Start) of opd)
(fetch (OpD ModStartAddr) of opd)
(fetch (OpD ForceNewOp) of opd])
(ShowFields
[LAMBDA NIL (* rtk "14-Apr-86 18:06")
(LET ((OPLIST NIL)
NAMELIST)
[FOR I IN MICROASSEMBLERCOMS DO (IF (AND (LISTP I)
(EQ 'PROP (CAR I)))
THEN (SETQ OPLIST (APPEND OPLIST (CDR I]
[SETQ OPLIST (FOR I IN OPLIST WHEN (LISTP (GETPROP I 'uField))
COLLECT (CONS I (CONS '%: (LET [(X (GETPROP I 'uField]
(IF (LISTP X)
THEN (FOR J IN X
COLLECT (CAR J))
ELSE X]
[SETQ NAMELIST (SORT (FOR I IN OPLIST COLLECT (CAR I]
(FOR I IN NAMELIST COLLECT (ASSOC I OPLIST])
(PutAssocHash
[LAMBDA (key val) (* rtk "18-Jul-86 09:52")
(if LabelList
then (PUTASSOC key val LabelList)
else (SETQ LabelList (LIST (CONS key val])
(GetAssocHash
[LAMBDA (key) (* rtk "17-Jul-86 16:05")
(CDR (FASSOC key LabelList])
(ShowUCodeAlloc
[LAMBDA (lableonly file) (* edited%: "29-Oct-86 14:57")
(if file
then (SETQ f (OPENSTREAM file 'OUTPUT))
else (SETQ f T))
(PRINTOUT f "A - Side of Rom" T)
[for i from 0 to 255 do (if (ELT UCodeRomA i)
then (if lableonly
then (PRINTOUT f i " " (fetch (MI Label)
of (ELT UCodeRomA i))
T)
else (PRINTOUT f i " " (fetch (MI Ucode)
of (ELT UCodeRomA i))
T]
(PRINTOUT f "B - Side of Rom" T)
[for i from 0 to 255 do (if (ELT UCodeRomB i)
then (if lableonly
then (PRINTOUT f i " " (fetch (MI Label)
of (ELT UCodeRomB i))
T)
else (PRINTOUT f i " " (fetch (MI Ucode)
of (ELT UCodeRomB i))
T]
(if (NEQ f T)
then (CLOSEF f])
(FindFreeSide
[LAMBDA (findside val Aaddr Baddr) (* edited%: "29-Oct-86 14:49")
[if findside
then (PROG (abad bbad)
[for i in val when (NEQ (CAR i)
'Addr) do [SETQ abad (OR abad (NUMBERP (fetch (MI
NextInstA
)
of (CADR i]
(SETQ bbad (OR bbad (NUMBERP (fetch (MI
NextInstB
)
of (CADR i]
(if (NOT bbad)
then (SETQ findside Baddr)
elseif (NOT abad)
then (SETQ findside Aaddr]
findside])
(FixLine
[LAMBDA (line) (* ; "Edited 3-Apr-87 17:40 by rtk")
(LET ((newline NIL)
pos lastpos nextpos)
(for i in line do [while [AND (SETQ pos (STRPOS "←" i))
(LESSP pos (NCHARS i))
(SETQ nextpos (STRPOS "←" i (PLUS pos 1)))
(LESSP nextpos (NCHARS i))
(NEQ (ADD1 nextpos)
(STRPOS "↑" i (PLUS pos 1]
do [SETQ newline (TCONC newline (SUBATOM i 1 (SUB1 nextpos]
(SETQ i (SUBATOM i (ADD1 pos]
(SETQ newline (TCONC newline i)))
(CAR newline])
)
(* * Misc)
(READVAR-FROM-STRING 'lineReadTable
"{D(34 37 40 41 44 59 91 93){R4 OTHER} SEPRCHAR BREAKCHAR OTHER OTHER }
")
(RPAQQ PreCondList (dump load reset pagefault ufn interrupt flush trapexit refill))
(PUTPROPS MICROASSEMBLER COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (827 45631 (AUCode 837 . 1673) (AssembleUCode 1675 . 3627) (SetAddrField 3629 . 6563) (
SwapAB 6565 . 7497) (CheckLabel 7499 . 8297) (CheckUndefinedLabels 8299 . 11715) (CollectLine 11717 .
12778) (FixEltLst 12780 . 14513) (NoteOpcode 14515 . 16261) (PutTamProps 16263 . 16798) (ParseElt
16800 . 20490) (ParseLine 20492 . 32947) (ParseLine2 32949 . 36587) (PutLabel 36589 . 39127) (
MakeOpList 39129 . 40114) (ReformatOpPla 40116 . 40604) (ShowFields 40606 . 41626) (PutAssocHash 41628
. 41861) (GetAssocHash 41863 . 42008) (ShowUCodeAlloc 42010 . 43552) (FindFreeSide 43554 . 44790) (
FixLine 44792 . 45629)))))
STOP