(FILECREATED " 5-Sep-86 20:36:04" {ERIS}<TAMARIN>UCODE>MICROASSEMBLER.;71 110600Q
changes to: (FNS AddVmTable AssembleOps ClearMemoryArray)
previous date: "22-Aug-86 17:38:18" {ERIS}<TAMARIN>UCODE>MICROASSEMBLER.;69)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT MICROASSEMBLERCOMS)
(RPAQQ MICROASSEMBLERCOMS ((FNS AUCode AssembleUCode AssignAddrs CheckLabel CheckUndefinedLabels
CollectLine FixEltLst NoteOpcode ParseElt ParseLine ParseLine2
PutLabel MakeOpList ReformatOpPla ShowFields PutAssocHash
GetAssocHash)
(* * Special Opcode Assembler)
(FNS AssembleOps AssembleOps.1 AddAtom ReadAtom AddItem AddList AddMemFrame AddCode LoadFnHdr
LinkCode AddFnHeader AddVmTable AddUfns NextFnAddr EvalBytes ClearMemoryArray)
(* * Misc)
(UGLYVARS lineReadTable)
(VARS PreCondList)))
(DEFINEQ
(AUCode
[LAMBDA (local) (* rtk "16-Jul-86 18:12")
(SETQ local (if (EQ local T)
then (QUOTE {DSK}TUCODE)
elseif local
then local
else (QUOTE {eris}<Tamarin>Ucode>TUCODE)))
(CLOSEF? local)
(AssembleUCode local)
(CLOSEF? local)
(SETQ undefinedlist (for i in labellist when (NOT (FMEMB i startlist)) collect
i])
(AssembleUCode
[LAMBDA (file) (* rtk "18-Jul-86 09:45")
(PROG (fl mi line fixLst)
(SETQ defaultlist NIL)
(SETQ startlist NIL)
(SETQ labellist NIL)
(SETQ fl (INPUT (INFILE file)))
(SETQ OpCodeList NIL)
(SETQ OpPlaArray (ARRAY 256 (QUOTE POINTER)
NIL 0))
(SETQ OpPlaSpec (LIST (QUOTE ((#Opcode 0 8 0)
(*DoReset 8 1 0)
(#Interrupt 9 1 0)
(#RefillRq 10 1 0)
(#FramesEmpty 11 1 0)
(#FramesFull 12 1 0)
(#$RefCnt 13 1 0)
(#$Refresh 14 1 0)
(#$StackRefill 15 1 0)))
(QUOTE ((#OpLength 0 3 0)
(#StartAddr 3 8 0)
(#ModStartAddr 11 1 0)
(#ForceNewOp 17 1 0)))
NIL))
(SETQ UCodeRom (ARRAY 257 (QUOTE POINTER)
NIL 0))
(SETQ LabelList NIL)
(PutLabel (QUOTE done)
256)
(SETQ AtomList NIL)
(for i in PreCondList do (PUTPROP i (QUOTE PreCondStart)
0))
(SETQ EltLst NIL)
(SETQ OpPlaList NIL)
(SETQ OpPlaTerms NIL)
L1 (SETQ line (CollectLine fl))
(SETQ mi (ParseLine line))
(if (EQ T mi)
then (GO L2))
(SETQ AtomList (LDIFFERENCE AtomList AtomList))
(* if mi then (if (ELT UCodeArray (CAR mi)) then (printout T "mi already present - addr=" (CAR mi) T))
(SETA UCodeArray (CAR mi) (CADR mi)))
(GO L1)
L2 (SETQ line (CollectLine fl))
(SETQ mi (ParseLine2 line OpPlaArray))
(if (EQ T mi)
then (GO L4))
(GO L2)
L4 (CheckUndefinedLabels)
(RPLACA (CDDR OpPlaSpec)
(for i in OpPlaList collect (ReformatOpPla i)))
(* for i from 0 to 255 when (NOT (ELT OpPlaArray i)) do (SETA OpPlaArray i (create OpD OpName ←
(QUOTE Undefined) OpNbr ← i Start ← 0 Length ← 0)))
(PROG [(UCODELEFT (for i from 0 to 255 count (NOT (ELT UCodeRom i]
(PRINTOUT T "Pla locations used: " (LENGTH OpPlaList)
T)
(PRINTOUT T UCODELEFT " Microcode Locations Left out of " (ARRAYSIZE UCodeRom)
T))
(CLOSEF fl])
(AssignAddrs
[LAMBDA (name start cnt offset) (* agb: " 6-May-86 20:51")
(PROG (addr) (* The 20Q can be less restrictive -
i has to be (LOGOR i offset ...))
[SETQ addr (for i from offset to 400Q by 20Q
thereis (for j from i to (PLUS i cnt)
always (NOT (ELT UCodeRom j]
(for nm in start as j from addr do (PutLabel nm j))
(RETURN addr])
(CheckLabel
[LAMBDA (datum field label) (* rtk "17-Jul-86 15:15")
(PROG (a)
(if (NUMBERP label)
then (RECORDACCESS field datum NIL (QUOTE REPLACE)
label)
(RETURN))
(if (NOT label)
then (HELP))
(SETQ a (GetAssocHash label))
(if (NUMBERP a)
then (RECORDACCESS field datum NIL (QUOTE REPLACE)
a)
else (PutAssocHash label (CONS (LIST field datum)
a])
(CheckUndefinedLabels
[LAMBDA NIL (* rtk "17-Jul-86 16:19")
(for i in (SORT LabelList T) do (PROG (addr (val (CDR i))
(key (CAR i)))
(if (LISTP val)
then
(if [NOT (for v in val
thereis
(EQ (QUOTE Addr)
(CAR v]
then (PRINTOUT T "Undefined label - "
key T))
[SETQ addr
(for i from 0 to 256
thereis (NOT (ELT UCodeRom i]
(for v in val
do (if (EQ (CAR v)
(QUOTE Addr))
then (SETA UCodeRom addr
(CADR v)))
(RECORDACCESS (CAR v)
(CADR v)
NIL
(QUOTE REPLACE)
addr])
(CollectLine
[LAMBDA (file) (* agb "23-Jul-85 20:48")
(PROG (c)
(RETURN (until [OR (EOFP file)
(EQ (QUOTE ;)
(SETQ c (READ file lineReadTable]
collect c])
(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)
(QUOTE (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 len) (* rtk " 7-May-86 11:44")
(PUTPROP (SETQ xname (U-CASE name))
(QUOTE TamarinOp)
(LIST addr len))
(SETQ OpCodeList (CONS (LIST xname addr len)
OpCodeList))
(if (ELT opArray addr)
then (printout T "Opcode already defined - nbr=" addr T))
(SETA opArray addr (LIST xname opd])
(ParseElt
[LAMBDA (elt1 prop) (* rtk "17-Jul-86 15:27")
(PROG (fval val type elt pos)
[if (EQ elt1 (QUOTE *))
then (RETURN (QUOTE (Comment]
(SETQ pos (STRPOS "←" elt1))
(if pos
then [SETQ val (L-CASE (MKATOM (SUBSTRING elt1 (ADD1 pos]
(SETQ AtomList (CONS (MKATOM (SUBSTRING elt1 (ADD1 pos)))
AtomList))
[SETQ elt (L-CASE (MKATOM (SUBSTRING elt1 1 (SUB1 pos]
(SETQ AtomList (CONS (MKATOM (SUBSTRING elt1 1 (SUB1 pos)))
AtomList))
else (SETQ elt (L-CASE elt1))
(SETQ AtomList (CONS (MKATOM elt1)
AtomList))
(SETQ val T))
(SETQ type (GETPROP elt prop))
(if (AND (NOT (FMEMB elt defaultlist))
(LISTP type)
(LISTP (CAR type))
(EQ (CADAR type)
0))
then (SETQ EltLst (CONS (LIST elt (CAAR type))
EltLst))
(SETQ defaultlist (CONS elt defaultlist))
(if (NEQ (CAAR type)
val)
then (SETQ EltLst (CONS (LIST elt val)
EltLst)))
else (SETQ EltLst (CONS (LIST elt val)
EltLst)))
(if (EQ type (QUOTE val))
then [if (NUMBERP val)
then (SETQ fval val)
else (SETQ fval (GETPROP val (QUOTE TamConst]
elseif (AND (EQ type (QUOTE atom))
(LITATOM val))
then (SETQ fval val)
elseif (LISTP type)
then (SETQ fval (CADR (FASSOC val type)))
(if (AND (NOT fval)
(NUMBERP val))
then (SETQ fval val)
elseif (AND (EQ prop (QUOTE uField))
(LISTP fval))
then (SETQ fval (EVAL fval)))
elseif (AND (EQ type (QUOTE Flag))
(EQ val T))
then (SETQ fval 1)
elseif (AND (EQ type (QUOTE Label))
(OR (LITATOM val)
(NUMBERP val)))
then (SETQ fval val))
(if (NOT fval)
then (PRINT line)
(PRIN1 "Unknown field - ")
(PRIN1 elt)
(PRIN1 "←")
(PRINT val)
(RETURN NIL))
(RETURN (LIST elt fval val])
(ParseLine
[LAMBDA (line) (* rtk "16-Jul-86 10:34")
(PROG ((muxrdselchk NIL)
hadEUop hadRaddr hadRD1addr hadRD2addr hadWrite hadTag hadWCycle hadDswap mi addr res
val label nextinsta nextinstb)
(if (EQ (CAR line)
(QUOTE End))
then (RETURN T))
(if (EQ (CAR line)
(QUOTE *))
then (RETURN NIL))
(SETQ mi (create MI))
(replace (MI Ucode) of mi with line)
(for elt in line
do (SETQ res (ParseElt elt (QUOTE uField)))
(SETQ val (CADR res))
(SELECTQ (CAR res)
(addr (SETQ addr val))
(label (SETQ label val)
(SETQ labellist (NCONC1 labellist val)))
(newbotcxt (replace (MI NewBotCxt) of mi with val))
(newtopcxt (replace (MI NewTopCxt) of mi with val))
(rcxt (replace (MI RCxt) of mi with val))
(wcxt (replace (MI WCxt) of mi with val))
(cycle [SETQ hadWCycle (FMEMB (CADDR res)
(QUOTE (w1 s4]
(replace (MI Cycle) of mi with val))
(euop (SETQ hadEUop T)
(replace (MI EUop) of mi with val))
(tag (SETQ hadTag T)
(replace (MI Tag) of mi with val))
(muxrdsel (if muxrdselchk
then (BREAK1 NIL T (Field used twice)
NIL)
else (SETQ muxrdselchk val)
(replace (MI MuxRdSel) of mi with val)))
(rd1addr (SETQ hadRD1addr T)
(replace (MI RD1addr) of mi with val))
(raddr (SETQ hadRaddr T)
(replace (MI Raddr) of mi with val))
(rd2addr (SETQ hadRD2addr (CADDR res))
(replace (MI RD2addr) of mi with val))
(dswap (SETQ hadDswap T)
(replace (MI Dswap) of mi with 1))
(waddr (SETQ hadWrite T)
(replace (MI Waddr) of mi with val))
(w2addr (SETQ hadWrite T)
(replace (MI W2addr) of mi with val))
(arg' (replace (MI Arg') of mi with val))
(tos' (replace (MI Tos') of mi with val))
(newtos (replace (MI NewTos) of mi with val))
(k (replace (MI K) of mi with val))
(newarg (replace (MI NewArg) of mi with val))
(newarg2 (replace (MI NewArg2) of mi with val))
(condcode (replace (MI CondCode) of mi with val))
(cwrite (replace (MI CWrite) of mi with 1))
(misc (replace (MI Misc) of mi with val))
[nextinsta (SETQ nextinsta val)
(if (NOT (FMEMB val startlist))
then (SETQ startlist (NCONC1 startlist val]
[nextinstb (SETQ nextinstb val)
(if (NOT (FMEMB val startlist))
then (SETQ startlist (NCONC1 startlist val]
(Comment (GO L1))
(NIL NIL)
(HELP)))
L1 [if (NOT label)
then (SETQ label (GENSYM (QUOTE LAB]
(replace (MI Label) of mi with label)
(if addr
then (PutLabel label addr)
(replace (MI Addr) of mi with addr)
else (CheckLabel mi (QUOTE 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 (QUOTE NextInstA]
else (CheckLabel mi (QUOTE NextInstA)
(if (EQ nextinsta (QUOTE rpt))
then label
else nextinsta)))
(if (NOT nextinstb)
then (if (NEQ 0 (fetch (MI CondCode) of mi))
then (SETQ fixLst (CONS (LIST mi (QUOTE NextInstB))
fixLst)))
else (CheckLabel mi (QUOTE NextInstB)
(if (EQ nextinstb (QUOTE 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 [OR (AND (AND hadRaddr (NOT hadDswap))
hadRD1addr)
(AND (AND hadRaddr hadDswap)
(AND hadRD2addr (NEQ hadRD2addr (QUOTE raddr-1]
then (PRINT line)
(PRINTOUT T "Conflicting read addresses" T))
(RETURN (LIST addr mi])
(ParseLine2
[LAMBDA (line opArray) (* rtk "16-Jun-86 16:33")
(PROG (opd opNbr res name val start opcnt ucaddr opMsk ucCnt (opSelect 0)
(opMask 0))
(if (EQ (CAR line)
(QUOTE End))
then (RETURN T))
(SETQ opd (create OpD))
(for elt in line
do (SETQ res (ParseElt elt (QUOTE uField2)))
(SETQ val (CADR res))
(SELECTQ (CAR res)
(opname (SETQ name (NCONC1 name val)))
(opnbr (SETQ opNbr val))
(opcnt (SETQ opcnt val))
[precond (SETQ opSelect (LOGOR opSelect (CAR val)))
(SETQ opMask (LOGOR opMask (CADR val]
(length (SETQ len val))
(start (SETQ start (NCONC1 start val))
(SETQ startlist (NCONC1 startlist val)))
(modstartaddr (replace (OpD ModStartAddr) of opd with 1))
(forcenewop (replace (OpD ForceNewOp) of opd with 1))
(PRINTOUT T "Unknown Field - " res T)))
(replace (OpD Length) of opd with len)
(if (NOT len)
then (HELP "Not enough Opcode info - " line))
(SETQ opcnt (if opcnt
then opcnt
elseif name
then (LENGTH name)
else (LENGTH start)))
(SETQ ucCnt (LENGTH start))
(if [NOT (MEMB opcnt (QUOTE (1 2 4 10Q 20Q 400Q]
then (HELP))
(if (TF (fetch (OpD ModStartAddr) of opd))
then (if (NEQ ucCnt opcnt)
then (HELP))
else (if (NEQ 1 ucCnt)
then (HELP)))
(SETQ opMsk (SUB1 opcnt))
(if (NEQ 0 (LOGAND opNbr opMsk))
then (HELP))
(if (NEQ 1 ucCnt)
then (SETQ ucaddr (AssignAddrs name start ucCnt (LOGAND opNbr 17Q)))
(replace (OpD Start) of opd with ucaddr)
else (CheckLabel opd (QUOTE Start)
(CAR start)))
(replace (OpD Val) of opd with (LOGOR opNbr opSelect))
[replace (OpD Mask) of opd with (LOGOR opMask (if (EQ 400Q opcnt)
then 0
else 163400Q)
(LOGAND 377Q (LOGNOT opMsk]
(for nm in name as i from 0 do (NoteOpcode nm (PLUS opNbr i)
len))
(SETQ OpPlaList (NCONC1 OpPlaList opd))
(SETQ OpPlaTerms (NCONC1 OpPlaTerms (ReformatOpPla opd)))
(RETURN (LIST opNbr opd])
(PutLabel
[LAMBDA (label val) (* rtk "17-Jul-86 15:21")
(PROG (a flg)
(SETQ a (GetAssocHash label))
(if (NUMBERP a)
then (PRINTOUT T "Multiply defined label - " label T)
(RETURN))
(if (LISTP a)
then (for i in a
do (if (EQ (QUOTE Addr)
(CAR i))
then (SETQ flg T)
(if (ELT UCodeRom val)
then (PRINTOUT T "Multiply defined ucode location - "
val T))
(SETA UCodeRom val (CADR i)))
(RECORDACCESS (CAR i)
(CADR i)
NIL
(QUOTE REPLACE)
val)))
(if (NOT flg)
then (if (NOT (EQ label (QUOTE done)))
then (PRINTOUT T "Undefined ucode location - " label T)
else (SETA UCodeRom val T)))
(PutAssocHash label val])
(MakeOpList
[LAMBDA (FILE) (* rtk "12-May-86 15:58")
(SETQ FILE (OPENFILE FILE (QUOTE 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 (QUOTE 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 (QUOTE PROP)
(CAR I)))
THEN (SETQ OPLIST (APPEND OPLIST (CDR I]
[SETQ OPLIST (FOR I IN OPLIST WHEN (LISTP (GETPROP I (QUOTE uField)))
COLLECT (CONS I (CONS (QUOTE :)
(LET [(X (GETPROP I (QUOTE 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])
)
(* * Special Opcode Assembler)
(DEFINEQ
(AssembleOps
[LAMBDA (oplist clearFirst?) (* edited: "22-Aug-86 16:30")
(* * note- it is assumed that no-one messes with FreeMemIndex except during AssembleOps -- it is also assumed that
if you ask for the clearFirst? that you will set up FreeMemIndex in the Tamarin, e.g. via tamSetUp)
(LET (opl (start 0))
(DECLARE (SPECVARS start))
(if (OR clearFirst? (NOT (BOUNDP (QUOTE FreeMemIndex)))
(NOT FreeMemIndex))
then (ClearMemoryArray)
(AddVmTable)
else (SETQ FreeMemIndex (ReadAtom (QUOTE FreeMemIndex)
(QUOTE val)
T)))
(AND oplist (SETQ CurrentOpList (APPEND oplist)))
(SETQ opl CurrentOpList)
(AssembleOps.1 opl)
(AddAtom (QUOTE FreeMemIndex)
FreeMemIndex])
(AssembleOps.1
[LAMBDA (opl) (* jmh "30-May-86 09:24")
(DECLARE (USEDFREE start))
(PROG (x)
L1 (if (NOT opl)
then (RETURN))
[COND
((EQ (QUOTE @)
(CAR opl))
[SETQ start (TIMES 4 (EVAL (CADR opl]
(SETQ opl (CDDR opl))
(GO L1))
((EQ (QUOTE *)
(CAR opl))
(SETQ x (EVALV (CADR opl)))
(if (AND x (NLISTP x))
then (printout T "Bad indirect list" (CADR opl)
T)
else (AssembleOps.1 x))
(SETQ opl (CDDR opl))
(GO L1))
((NUMBERP (CAR opl))
(StoreTamByte start (CAR opl)))
[(LISTP (CAR opl))
(if (EQ (CAAR opl)
(QUOTE EvalBytes))
then (for i in (EVAL (CAR opl))
do (StoreTamByte start i)
(SETQ start (ADD1 start)))
(SETQ opl (CDR opl))
(GO L1)
elseif (EQ (CAAR opl)
(QUOTE *))
then (SETQ opl (CDR opl))
(GO L1)
else (StoreTamByte start (EVAL (CAR opl]
((SETQ x (GETPROP (U-CASE (CAR opl))
(QUOTE TamarinOp)))
(StoreTamByte start (CAR x)))
(T (PRIN1 "Unknown Op: ")
(PRINT (CAR opl]
(SETQ opl (CDR opl))
(SETQ start (ADD1 start))
(GO L1])
(AddAtom
[LAMBDA (atom val def prop) (* rtk "21-May-86 12:02")
(PROG ((index (GETHASH atom AtomHashArray)))
[if (NOT index)
then (PUTHASH atom FreeMemIndex AtomHashArray)
(SETQ index FreeMemIndex)
(SETQ FreeMemIndex (IPLUS FreeMemIndex 5))
(for i from 0 to 4 do (MemoryAccess (IPLUS i index)
(TamRep (QUOTE Unbound]
(if val
then (MemoryAccess (IPLUS 1 index)
val))
(if def
then (MemoryAccess (IPLUS 2 index)
def))
(if prop
then (MemoryAccess (IPLUS 3 index)
prop))
(MemoryAccess (IPLUS 4 index)
(TamRep (\LOLOC atom)))
(RETURN (TamRep (QUOTE Atm)
index])
(ReadAtom
[LAMBDA (atom part noTypeBits?) (* jmh "29-May-86 12:53")
(LET [(result (MemoryAccess (PLUS (OR (GETHASH atom AtomHashArray)
(HELP "atom not yet defined" atom))
(SELECTQ (OR part (QUOTE val))
(val 1)
(def 2)
(prop 3)
(HELP "bad part" part]
(if noTypeBits?
then (LOGAND result (MASK.1'S 0 24))
else result])
(AddItem
[LAMBDA (item) (* rtk "12-May-86 17:36")
(if item then (if (NUMBERP item)
then
(TamRep item)
elseif
(LISTP item)
then
(AddList item)
elseif
(LITATOM item)
then
(AddAtom item)
else
(BREAK1 NIL T (AddItem Error)
NIL))
else
(TamRep (QUOTE NIL])
(AddList
[LAMBDA (list) (* rtk "14-May-86 10:18")
(if list
then (if (LISTP list)
then (PROG ((Index FreeMemIndex))
(SETQ FreeMemIndex (IPLUS FreeMemIndex 2))
(MemoryAccess Index (AddItem (CAR list)))
(MemoryAccess (ADD1 Index)
(AddItem (CDR list)))
(RETURN (TamRep (QUOTE List)
Index)))
else (AddItem list))
else (TamRep (QUOTE NIL])
(AddMemFrame
[LAMBDA (NextFrame) (* rtk "16-Jul-86 10:47")
(SETQ FreeMemIndex (CEIL FreeMemIndex WORDSPERQUAD))
(PROG ((Ptr FreeMemIndex)
(FrameSize 54Q))
(for i from FreeMemIndex to (PLUS FreeMemIndex FrameSize)
do (MemoryAccess i (TamRep (QUOTE Unbound))
T))
(MemoryAccess (PLUS FreeMemIndex 3)
NextFrame)
(SETQ FreeMemIndex (PLUS FreeMemIndex FrameSize))
(RETURN (TamRep (QUOTE Frame)
Ptr])
(AddCode
[LAMBDA (theAtom) (* jmh "22-May-86 10:50")
(* * download the TCODE property of theAtom <error if none> -- return the TamRep of the Tamarin-memory CODEP -- the
TCODE property is a list: CAR is a byte array, some of the function-header fields of which need massaging;
CDR is a list of either <atom 3 byteOffset> or <listp 4 byteOffset> telling what bytes need to be patched with the
TamRep of what)
(DECLARE (GLOBALVARS FreeMemIndex))
(if (NOT FreeMemIndex)
then (ERROR "FreeMemIndex uninitialized"))
(LET ((theTCodeProperty (GETPROP theAtom (QUOTE TCODE)))
codePAddr theTCodeP theLinkInfo nrBytes nrWords nrWordsInHdr nrBytesInHdr)
(if [NOT (AND (LISTP theTCodeProperty)
(PROGN (SETQ theTCodeP (CAR theTCodeProperty))
(SETQ theLinkInfo (CDR theTCodeProperty))
(ARRAYP theTCodeP))
(EQ (ARRAYTYP theTCodeP)
(QUOTE BYTE))
(EQ 0 (ARRAYORIG theTCodeP))
(EQ (SETQ nrBytes (ARRAYSIZE theTCodeP))
(CEIL nrBytes BYTESPERCELL]
then (ERROR theAtom "has bad TCode Property"))
(* * allocate space for the tcodep -- first round up FreeMemIndex as necessary to be quad-word aligned, just in
case)
(SETQ codePAddr (SETQ FreeMemIndex (CEIL FreeMemIndex WORDSPERQUAD)))
(SETQ nrWords (FOLDHI nrBytes BYTESPERCELL))
(add FreeMemIndex nrWords)
(* * load header)
(SETQ nrWordsInHdr (LoadFnHdr codePAddr theTCodeP nrWords))
(SETQ nrBytesInHdr (UNFOLD nrWordsInHdr BYTESPERCELL))
(* * load body of code -- NOTE: old-format name tables loaded as is, as code)
(for fromByteAddr from nrBytesInHdr to (SUB1 nrBytes) as toByteAddr
from (IPLUS (UNFOLD codePAddr BYTESPERCELL)
nrBytesInHdr)
do (StoreTamByte toByteAddr (ELT theTCodeP fromByteAddr)))
(* * linking of atoms and listps -- where the code refers to atom or list literals, ensure that they exist in the
Tamarin, and patch their representations into the byte stream)
(LinkCode codePAddr theLinkInfo)
(* * done)
(TamRep (QUOTE Code)
codePAddr])
(LoadFnHdr
[LAMBDA (tamBase theTCodeP objectSize) (* jmh "12-Jun-86 16:28")
(* * store Tamarin-memory form of TFNHDR of TCODEP to Tamarin memory at CODEPADDR -- return number of cells in
function header -- * * doesn't copy FLAGS now -- includes entry vector that immediately follows fn hdr proper)
(LET ((hdrSize 8)
(fnHdr (ARRAYBASEPTR theTCodeP))
(self (TamRep (QUOTE Code)
tamBase)))
(if (NEQ hdrSize (fetch (TFNHDR OVERHEADCELLS) of T))
then (SHOULDNT "Tam fn hdr size changed?"))
(MemoryAccess (PLUS 0 tamBase)
(TamRep (QUOTE Unbound))) (* OBJECTHEADERCELL)
(MemoryAccess (PLUS 1 tamBase)
(TamRep (QUOTE Int)
objectSize))
(MemoryAccess (PLUS 2 tamBase)
(AddAtom (fetch (TFNHDR FRAMENAME) of fnHdr)))
[MemoryAccess (PLUS 3 tamBase)
(TamRep (QUOTE Int)
(LOGOR (LLSH (fetch (TFNHDR NTSIZE) of fnHdr)
16)
(LLSH (fetch (TFNHDR NLOCALS) of fnHdr)
8)
(fetch (TFNHDR FVAROFFSET) of fnHdr]
[MemoryAccess (PLUS 4 tamBase)
(TamRep (QUOTE Int)
(LOGOR (LLSH (fetch (TFNHDR MAXVAR) of fnHdr)
16)
(LLSH (fetch (TFNHDR USECOUNT) of fnHdr)
8)
(fetch (TFNHDR SP) of fnHdr]
(MemoryAccess (PLUS 5 tamBase)
(TamRep (QUOTE Unbound)))
(MemoryAccess (PLUS 6 tamBase)
self)
(MemoryAccess (PLUS 7 tamBase)
self)
[for I from 0 to 7 do (MemoryAccess (PLUS I hdrSize tamBase)
(TamRep (QUOTE Int)
(IPLUS (TFNHDR.EVN fnHdr I)
(LLSH
(LOGAND tamBase
(MASK.1'S
0 24))
2]
(PLUS hdrSize 8])
(LinkCode
[LAMBDA (codeAddr linkInfos) (* jmh "22-May-86 10:52")
(* * patch a codep in Tamarin memory with link information -- codeAddr is the Tamarin address of the codep --
linkInfos is a list of <thing nrBytes byteOffset>, each saying of a thing that it needs to be in the Tamarin
memory, and that the right nrBytes of its Tamarin pointer representation needs to be patched into the codep
starting at the byteOffset -- atom and list literals are supported)
(for linkInfo in linkInfos bind theThing nrBytes theTamRep
do (SETQ theThing (CAR linkInfo))
(SETQ nrBytes (CADR linkInfo))
(SETQ byteOffset (CADDR linkInfo))
(SETQ theTamRep (if (LITATOM theThing)
then (if (MEMB theThing (QUOTE (NIL T UNBIND)))
then (TamRep theThing)
else (AddAtom theThing))
elseif (LISTP theThing)
then (AddList theThing)
else (HELP "not atom nor list" theThing)))
(* * emit least sig byte first)
(for counter from 1 to nrBytes as bytePointer from (PLUS (UNFOLD codeAddr
BYTESPERCELL)
byteOffset)
do (StoreTamByte bytePointer (LOGAND theTamRep 255))
(SETQ theTamRep (LRSH theTamRep 8])
(AddFnHeader
[LAMBDA (fnname wordat sp) (* rtk "13-Jun-86 17:34")
(if (NOT wordat)
then (SETQ wordat (QUOTIENT (PLUS start 3)
4)))
(if (NOT sp)
then (SETQ sp 20Q))
(PROG ((at (CEIL wordat WORDSPERQUAD))
newat)
(AddAtom fnname NIL (TamRep (QUOTE Code)
at))
(SETQ newat (PLUS at 14Q))
(SETQ newatbyte (TIMES newat 4))
(for I from 0 to 3 do (MemoryAccess (PLUS I at)
(TamRep 0)))
(MemoryAccess (PLUS at 4)
(TamRep sp))
(MemoryAccess (PLUS at 5)
(TamRep 0))
(MemoryAccess (PLUS at 6)
(TamRep (QUOTE Code)
at))
(MemoryAccess (PLUS at 7)
(TamRep (QUOTE Code)
at))
(for I from 0 to 7 do (MemoryAccess (PLUS at 10Q I)
(TamRep newatbyte)))
(SETQ start newatbyte])
(AddVmTable
[LAMBDA (Where Size NotPresent WriteProtect) (* edited: " 5-Sep-86 20:35")
(if (NOT Where)
then (SETQ Where 4000Q))
(if (NOT Size)
then (SETQ Size 10000Q))
(PROG ((pageaddr 0))
(for i from Where to (PLUS Where Size)
do (MemoryAccess i (TamRep (LOGOR (if NotPresent
then 0
else 1)
(if WriteProtect
then 0
else 2)
(LLSH pageaddr 2)))
T)
(SETQ pageaddr (ADD1 pageaddr])
(AddUfns
[LAMBDA (ufnList) (* jmh "20-May-86 15:04")
(* * ufnList is a list of <opname ufnname>s -- get all these ufn fns' tcodeps downloaded and their addresses in the
Tamarin's ufn table -- that table is pointed to by the tamarin atom UfnTable -- note does not create Tamarin atoms
naming the ufn functions)
(LET [(ufnTableBase (LOGAND (MASK.1'S 0 30)
(MemoryAccess (ADD1 (LOGAND (MASK.1'S 0 24)
(AddAtom (QUOTE UfnTable]
(* i.e. the contents of the value cell of the already
existing tamarin atom UfnTable, as a raw number)
(for X in ufnList bind opName ufnName opNr
do (SETQ opName (CAR X))
(SETQ ufnName (CADR X))
(if [NOT (SETQ opNr (for I from 0 to 255
thereis (EQ opName (CAR (ELT OpPlaArray I]
then (HELP "opName not in OpPlaArray" opName))
(MemoryAccess (PLUS ufnTableBase opNr)
(AddCode ufnName])
(NextFnAddr
[LAMBDA NIL (* rtk "16-Jun-86 11:16")
(PLUS (QUOTIENT (PLUS start 3)
4)
10000000Q])
(EvalBytes
[LAMBDA (bytes expr) (* agb: "14-Aug-86 15:11")
(PROG (word (wstart (QUOTIENT (PLUS start 3)
4))
(val (EVAL expr)))
(if (EQ bytes 0)
then (RETURN NIL))
(if (GREATERP bytes 0)
then [RETURN (for i from 1 to bytes
collect (LOGAND 377Q (RSH val (TIMES (IDIFFERENCE
i 1)
10Q]
else (if (NEQ (ABS bytes)
(LOGAND (ABS bytes)
74Q))
then (BREAK1 NIL T (Need Even Word offset)
NIL))
[SETQ val (for i from (ABS bytes) to 1 by -1
collect (LOGAND 377Q (RSH val (TIMES (IDIFFERENCE
i 1)
10Q]
(while val
do (MemoryAccess wstart (IPLUS (LSH (CAR val)
30Q)
(LSH (CADR val)
20Q)
(LSH (CADDR val)
10Q)
(CADDDR val)))
(SETQ wstart (ADD1 wstart))
(SETQ start (TIMES wstart 4))
(SETQ val (CDDDDR val)))
(RETURN NIL])
(ClearMemoryArray
[LAMBDA NIL (* edited: "22-Aug-86 16:32")
(SETQ lastwrd 0)
(for i from 0 to (SUB1 (ARRAYSIZE MemoryArray)) do (SETA MemoryArray i 0))
(if (BOUNDP (QUOTE AtomHashArray))
then (CLRHASH AtomHashArray)
else (SETQ AtomHashArray (HARRAY 100)))
(SETQ FreeMemIndex 8192)
(AddAtom (QUOTE FreeMemIndex)
FreeMemIndex])
)
(* * Misc)
(READVARS 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" 3701Q 3702Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1560Q 50621Q (AUCode 1572Q . 2551Q) (AssembleUCode 2553Q . 7205Q) (AssignAddrs 7207Q .
10254Q) (CheckLabel 10256Q . 11326Q) (CheckUndefinedLabels 11330Q . 13154Q) (CollectLine 13156Q .
13610Q) (FixEltLst 13612Q . 15622Q) (NoteOpcode 15624Q . 16524Q) (ParseElt 16526Q . 23441Q) (ParseLine
23443Q . 35223Q) (ParseLine2 35225Q . 42371Q) (PutLabel 42373Q . 44312Q) (MakeOpList 44314Q . 45532Q)
(ReformatOpPla 45534Q . 46423Q) (ShowFields 46425Q . 50010Q) (PutAssocHash 50012Q . 50370Q) (
GetAssocHash 50372Q . 50617Q)) (50667Q 110130Q (AssembleOps 50701Q . 52532Q) (AssembleOps.1 52534Q .
55510Q) (AddAtom 55512Q . 57253Q) (ReadAtom 57255Q . 60222Q) (AddItem 60224Q . 61126Q) (AddList 61130Q
. 62222Q) (AddMemFrame 62224Q . 63317Q) (AddCode 63321Q . 70151Q) (LoadFnHdr 70153Q . 74136Q) (
LinkCode 74140Q . 76761Q) (AddFnHeader 76763Q . 100777Q) (AddVmTable 101001Q . 102140Q) (AddUfns
102142Q . 104346Q) (NextFnAddr 104350Q . 104630Q) (EvalBytes 104632Q . 107147Q) (ClearMemoryArray
107151Q . 110126Q)))))
STOP