(FILECREATED "30-May-86 17:34:15" {ERIS}<TAMARIN>UCODE>FORCEOPNRS.;1 15206
changes to: (VARS FORCEOPNRSCOMS)
(FNS FORCEOPNRS MAKERANGES MAKERANGES.1 COMPAREOPS OCT SAMEOPS? TAKEUCODEOPNRS HEX
COMPAREOPS.HDG)
previous date: "13-May-86 12:41:57" {ERIS}<TAMARIN>WORK>DT>FORCEOPNRS.;5)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FORCEOPNRSCOMS)
(RPAQQ FORCEOPNRSCOMS ((* * FORCEOPNRS forces \TAMOPCODES' ops to correspond to OpCodeList <output
of AUCode> -- diagnostic messages and no action if correspondence is not
close enough -- you will have to make TOPCODE records for totally new
opcodes <with arbitrary opcode numbers> before FORCEOPNRS will complete
-- you will have to make \TAMOPCODEARRAY via some other mechanism)
(FNS FORCEOPNRS)
(FNS MAKERANGES MAKERANGES.1)
(FNS COMPAREOPS COMPAREOPS.HDG)
(* * other possibly useful stuff)
(FNS LISTOPS LISTRANGEOPS)
(FNS SAMEOPS?)
(FNS OPNRSAVAIL OPNRUSED)))
(* * FORCEOPNRS forces \TAMOPCODES' ops to correspond to OpCodeList <output of AUCode> --
diagnostic messages and no action if correspondence is not close enough -- you will have to
make TOPCODE records for totally new opcodes <with arbitrary opcode numbers> before FORCEOPNRS
will complete -- you will have to make \TAMOPCODEARRAY via some other mechanism)
(DEFINEQ
(FORCEOPNRS
[LAMBDA (TUOPS) (* jmh "30-May-86 14:32")
(* * force \TAMOPCODES op#s per TUOPS, which is a ranged ucode op list -- TUOPS defaults to the ranged opcode list
made from AUCode's output opcode list)
(OR TUOPS (SETQ TUOPS (MAKERANGES OpCodeList)))
(LET ((TAMOPS (COPYALL \TAMOPCODES))
X)
(if (SETQ X (COMPAREOPS TUOPS))
then X
elseif (SAMEOPS? \TAMOPCODES TUOPS)
then "no changes necessary"
else (SETQ \TAMOPCODES
(for TAMOP in TAMOPS bind OPNAME TUOP TUOPNR TAMOPNR
collect (SETQ OPNAME (fetch (TOPCODE OPCODENAME) of TAMOP))
(SETQ TUOP (ASSOC OPNAME TUOPS))
(if (NOT TUOP)
then (HELP "name missing" OPNAME))
(if (NEQ (CADDR TUOP)
(ADD1 (fetch (TOPCODE OPNARGS) of TAMOP)))
then (HELP "#args" TUOP))
(SETQ TUOPNR (CADR TUOP))
(SETQ TAMOPNR (fetch (TOPCODE OP#) of TAMOP))
(if (NEQ (NLISTP TUOPNR)
(NLISTP TAMOPNR))
then (HELP "rangeness" TUOP))
[if (LISTP TUOPNR)
then (LET [[TURANGE (ADD1 (DIFFERENCE (CADR TUOPNR)
(CAR TUOPNR]
(TAMRANGE (ADD1 (DIFFERENCE (CADR TAMOPNR)
(CAR TAMOPNR]
(if (NEQ TURANGE TAMRANGE)
then (printout T TUOP " range was" TAMRANGE
" now "
TURANGE T]
(replace (TOPCODE OP#) of TAMOP with TUOPNR)
TAMOP))
(SETQ \TAMOPCODEARRAY NIL)
"please run TOP.EDIT to load this \TAMOPCODES and set \TAMOPCODEARRAY"])
)
(DEFINEQ
(MAKERANGES
[LAMBDA (INPUTOPS) (* jmh "30-May-86 15:32")
(* * INPUTOPS is a list of <opname opnumber oplength>s, the opnumbers being numbers -- return a similar list
<sorted by opname> where if an opname has a digit in it and isn't e.g. '0 and the number in the name matches the
low 4 bits of the opnumber and there is another opname of the same form then all the variants of that opname are
replaced by one entry: the K-form of that opname with number-range opnumber -- but various errors are just detected
and printed -- and there are various specials: <1> length 0 becomes 1, <2> see MAKERANGES.1)
(LET (OUTPUTOPS RANGEDOPS)
[for OP in (SORT (COPYALL INPUTOPS)
T)
bind X KOP
do (SETQ X (MAKERANGES.1 (CAR OP))) (* NIL OR: CAR is K-name, CADR is number, -- CADDR is
NIL or number to force length to)
(if (OR (NOT X)
(if (NEQ (CADR X)
(LOGAND 15 (CADR OP)))
then (printout T OP " taken as non-opK-format: low 4 bits wrong" T)
T))
then (push OUTPUTOPS OP)
else (if (SETQ KOP (ASSOC (CAR X)
RANGEDOPS))
else [SETQ KOP (LIST (CAR X)
NIL
(OR (CADDR X)
(CADDR OP]
(push RANGEDOPS KOP))
(if (NEQ (OR (CADDR X)
(CADDR OP))
(CADDR KOP))
then (printout T OP " skipped because length differs from that of "
KOP T)
elseif (MEMB (CADR OP)
(CADR KOP))
then (printout T OP " skipped because duplicated in " KOP T)
else (push (CADR KOP)
(CADR OP]
[for KOP in (SORT RANGEDOPS T) bind LASTOPNR FIRSTOPNR
do (SORT (CADR KOP))
(SETQ FIRSTOPNR (CAR (CADR KOP)))
[SETQ LASTOPNR (CAR (LAST (CADR KOP]
(if (NEQ (LENGTH (CADR KOP))
(ADD1 (IDIFFERENCE LASTOPNR FIRSTOPNR)))
then (printout T KOP " skipped because range not contiguous" T)
else (push OUTPUTOPS (LIST (CAR KOP)
(if (EQ FIRSTOPNR LASTOPNR)
then FIRSTOPNR
else (LIST FIRSTOPNR LASTOPNR))
(CADDR KOP]
(for X in OUTPUTOPS when (ZEROP (CADDR X)) do (RPLACA (CDDR X)
1))
(SORT OUTPUTOPS T])
(MAKERANGES.1
[LAMBDA (THEATOM) (* jmh "30-May-86 14:39")
(* * A is an atom -- if A has no digits in its pname, return NIL -- else return a list of 3 elements: <1> an atom
with pname = A's except with first number replaced by K, <2> the first number in A's pname, <3> if Length of op is
to be forced then the new value else NIL -- this is where special get applied)
(LET (CHARLIST NEWCHARLISTBEG THENUMBER NEWCHARLISTEND KATOM FORCELENGTH)
(SETQ CHARLIST (UNPACK THEATOM))
[SETQ KATOM (if (EQ THEATOM (QUOTE NOP))
then (SETQ THENUMBER 0)
(QUOTE NOPK)
elseif (EQ (SUBATOM THEATOM 1 3)
(QUOTE UDF))
then NIL
elseif (NOT (for C in CHARLIST thereis (NUMBERP C)))
then NIL
else [while [AND CHARLIST (NOT (NUMBERP (CAR CHARLIST]
do (SETQ NEWCHARLISTBEG (NCONC1 NEWCHARLISTBEG (pop
CHARLIST]
(SETQ THENUMBER 0)
[while (AND CHARLIST (NUMBERP (CAR CHARLIST)))
do (SETQ THENUMBER (IPLUS (ITIMES 10 THENUMBER)
(pop CHARLIST]
(SETQ NEWCHARLISTEND CHARLIST)
(PACK (APPEND NEWCHARLISTBEG (LIST (QUOTE K))
NEWCHARLISTEND]
(* * specials)
(SELECTQ KATOM
('K (SETQ KATOM NIL) (* simply shouldnt be grouped)
)
(FNK (SETQ KATOM NIL) (* can't be grouped because LevAdj varies)
)
((OVARK.X OVARK.X←)
(SETQ KATOM NIL) (* only one of each exists)
)
(NOPK (SETQ KATOM (QUOTE JUMPK))
(SETQ FORCELENGTH 1) (* only the hardware knows that JUMPk is really two
contiguous groups of opcodes)
)
KATOM)
(if (NOT KATOM)
then NIL
else (LIST KATOM THENUMBER FORCELENGTH])
)
(DEFINEQ
(COMPAREOPS
[LAMBDA (TUOPS PRINTANYWAY) (* jmh "30-May-86 15:26")
(* * print pretty comparison of \TAMOPCODES with something like <MAKERANGES TUCODEOPS> -- PRINTANYWAY means list
all ops; o/w list only when errors -- return NIL if no errors else <# errors>)
(LET ([TAMOPS (for X in \TAMOPCODES collect (LIST (fetch (TOPCODE OPCODENAME)
of X)
(fetch (TOPCODE OP#) of X)
(ADD1 (fetch (TOPCODE OPNARGS)
of X]
(TAMCOL 1)
(TUCOL 23)
(GONECOL 46)
(NEWCOL 56)
(NROPSCOL 66)
(NARGSCOL 76)
(NERRORS 0)
HDGPRINTED? ORIGTAMOPS ORIGTUOPS)
(SETQ ORIGTAMOPS (SETQ TAMOPS (SORT (COPYALL TAMOPS)
T)))
(SETQ ORIGTUOPS (SETQ TUOPS (SORT (COPYALL TUOPS)
T)))
(DECLARE (SPECVARS HDGPRINTED?))
[while (OR TAMOPS TUOPS)
do (SELECTQ (if (NOT TAMOPS)
then NIL
elseif (NOT TUOPS)
then (QUOTE LESSP)
else (ALPHORDER (CAAR TAMOPS)
(CAAR TUOPS)))
(LESSP (LET ((TAMOP (pop TAMOPS)))
(add NERRORS 1)
(COMPAREOPS.HDG)
(printout T .TAB TAMCOL TAMOP .TAB GONECOL
(if (EQ TAMOP (ASSOC (CAR TAMOP)
ORIGTAMOPS))
then "TamOnly"
else "duplInTam")
T)))
[EQUAL (LET ((TAMOP (pop TAMOPS))
(TUOP (pop TUOPS))
NROPSBAD NARGSBAD)
[SETQ NROPSBAD (NEQ (NLISTP (CADR TAMOP))
(NLISTP (CADR TUOP]
(SETQ NARGSBAD (NEQ (CADDR TAMOP)
(CADDR TUOP)))
(if (OR PRINTANYWAY NROPSBAD NARGSBAD)
then (COMPAREOPS.HDG)
(printout T .TAB TAMCOL TAMOP .TAB TUCOL TUOP)
(if NROPSBAD
then (add NERRORS 1)
(printout T .TAB NROPSCOL "rangeness")
)
(if NARGSBAD
then (add NERRORS 1)
(printout T .TAB NARGSCOL "length"))
(printout T T]
(LET ((TUOP (pop TUOPS)))
(add NERRORS 1)
(COMPAREOPS.HDG)
(printout T .TAB TUCOL TUOP .TAB NEWCOL
(if (EQ TUOP (ASSOC (CAR TUOP)
ORIGTUOPS))
then "TUOnly"
else "duplInTU")
T]
(if (ZEROP NERRORS)
then NIL
else (LIST NERRORS (QUOTE errors])
(COMPAREOPS.HDG
[LAMBDA NIL
(DECLARE (SPECVARS HDGPRINTED?)) (* jmh "16-May-86 10:48")
(if (NOT HDGPRINTED?)
then (printout T .TAB TAMCOL "tamops" .TAB TUCOL "tucodeops" .TAB GONECOL "problems..." T T)
(SETQ HDGPRINTED? T])
)
(* * other possibly useful stuff)
(DEFINEQ
(LISTOPS
[LAMBDA (OPS) (* jmh " 8-May-86 15:30")
(* * prettyprint e.g. \TAMOPCODES in alpha sort by name)
(DECLARE (GLOBALVARS \TAMOPCODES))
(OR OPS (SETQ OPS \TAMOPCODES))
(for X in [SORT (COPY OPS)
(FUNCTION (LAMBDA (A B)
(ALPHORDER (fetch (OPCODE OPCODENAME) of A)
(fetch (OPCODE OPCODENAME) of B]
do (printout T X T])
(LISTRANGEOPS
[LAMBDA (OPCODES) (* jmh "13-May-86 12:13")
(* * list the OPCODE records of the list OPCODES that have a range as OP# -- with range of implicit operands)
(if (NOT OPCODES)
then (SETQ OPCODES \TAMOPCODES))
(if (NLISTP OPCODES)
then "need opcodes array"
else (LET ((N 0))
(for OPCODE in OPCODES bind OPNR BASEOPNR
when (LISTP (SETQ OPNR (fetch (OPCODE OP#) of OPCODE)))
do (add N 1)
(printout T .I3.8.T (SETQ BASEOPNR (LOGAND 240 (CAR OPNR)))
"q")
(printout T , (IDIFFERENCE (CAR OPNR)
BASEOPNR)
(QUOTE -)
(IDIFFERENCE (CADR OPNR)
BASEOPNR))
(if (IGREATERP (IDIFFERENCE (CADR OPNR)
BASEOPNR)
15)
then (printout T " **not properly aligned**"))
(printout T , OPCODE T))
N])
)
(DEFINEQ
(SAMEOPS?
[LAMBDA (TAMOPS TUOPS) (* jmh "28-May-86 11:18")
(* * answer whether these correspond exactly)
(LET ((CTAMOPS (COPYALL TAMOPS))
(NROKTUOPS 0))
[for TUOP in TUOPS bind TAMOP
do (if [NOT (SETQ TAMOP (for TAMOP in CTAMOPS
thereis (EQ (CAR TUOP)
(fetch (OPCODE OPCODENAME)
of TAMOP]
then (printout T (CAR TUOP)
" no TAMOP" T)
else (SETQ CTAMOPS (DREMOVE TAMOP CTAMOPS))
(if (NOT (EQUAL (CADR TUOP)
(fetch (OPCODE OP#) of TAMOP)))
then (printout T (CAR TUOP)
" wrong OP#" T)
elseif (NEQ (CADDR TUOP)
(ADD1 (fetch (OPCODE OPNARGS) of TAMOP)))
then (printout T (CAR TUOP)
" bad length" T)
else (add NROKTUOPS 1]
(AND (NULL CTAMOPS)
(EQ NROKTUOPS (LENGTH TUOPS])
)
(DEFINEQ
(OPNRSAVAIL
[LAMBDA (OPCODES) (* jmh "13-May-86 12:14")
(* * print map of available opcode nrs)
(if (NOT OPCODES)
then (SETQ OPCODES \TAMOPCODES))
(if (NLISTP OPCODES)
then "bad OPCODES"
else (for NHI from 0 to 15
do (printout T .I1.16 NHI (QUOTE -))
(for NLO from 0 to 15 do (if (OPNRUSED (IPLUS NLO
(ITIMES NHI 16))
OPCODES)
then (printout T (QUOTE *))
else (printout T .I1.16 NLO)))
(printout T T])
(OPNRUSED
[LAMBDA (TARGETOPNR OPCODES) (* jmh "13-May-86 12:14")
(* * answer whether TARGETOPNR is used as an opcode nr in OPCODES)
(if (NOT OPCODES)
then (SETQ OPCODES \TAMOPCODES))
(if (OR (NOT (NUMBERP TARGETOPNR))
(MINUSP TARGETOPNR)
(IGREATERP TARGETOPNR 255))
then (HELP "bad OPNR" TARGETOPNR)
elseif (NLISTP OPCODES)
then (HELP "bad OPCODES" OPCODES)
else (for OPCODE in OPCODES bind OPNR thereis (if (NLISTP (SETQ OPNR
(fetch
(OPCODE OP#)
of OPCODE)))
then (EQ TARGETOPNR OPNR)
else (AND (IGEQ TARGETOPNR
(CAR OPNR))
(ILEQ TARGETOPNR
(CADR OPNR])
)
(PUTPROPS FORCEOPNRS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1411 3241 (FORCEOPNRS 1421 . 3239)) (3242 7978 (MAKERANGES 3252 . 5890) (MAKERANGES.1
5892 . 7976)) (7979 10961 (COMPAREOPS 7989 . 10663) (COMPAREOPS.HDG 10665 . 10959)) (11002 12529 (
LISTOPS 11012 . 11506) (LISTRANGEOPS 11508 . 12527)) (12530 13603 (SAMEOPS? 12540 . 13601)) (13604
15125 (OPNRSAVAIL 13614 . 14247) (OPNRUSED 14249 . 15123)))))
STOP