(FILECREATED "25-Jun-86 23:42:57" {ERIS}<TAMARIN>TUT>TUTBASE.;13 29828
changes to: (FNS StdUfn)
previous date: "25-Jun-86 16:11:46" {ERIS}<TAMARIN>TUT>TUTBASE.;12)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TUTBASECOMS)
(RPAQQ TUTBASECOMS [(* * base for Tamarin Microcode Testing **)
(* * * * * TEMPORARY * * * * *)
(* * need to put NOPs after anything that ufns or FNs -- in particular use NOP?
after CONSes and in ShouldUFN's etc and after all fncalls)
(VARS (NOP?CausesNOP T))
(FNS NOP?.GENC CONS.GENC)
(PROP TASMFN NOP? CONS)
(* * * * * ASSEMBLEOPS * * * * *)
(* * AssembleOps setup run)
(FNS AOSetup)
(VARS TUTSetup tamSetUp.TrivialFnhdr TUTSetup.IREGs)
(* * AssembleOps each-time stuff)
(FNS TPUTD TRun TRunForEffect TDo)
(VARS TUTInit)
(* * add standard testing ufns * *)
(FNS StdUfn)
(VARS CONS.TUFN)
[* after AOSetup -- (TDo (QUOTE (AddUfns (QUOTE ((CONS CONS.TUFN]
(P (TASMV (QUOTE CONS.TUFN)))
(* * * * * MACHINE DEFINITION * * * * *)
(* * constants)
[CONSTANTS (T.MaxInt (SUB1 (LLSH 1 29)))
(T.MinInt (MINUS (LLSH 1 29]
(* * cause Lisp "(STOP)" to turn into D-machine RAID opcode which then
translates to Tamarin STOP opcode -- the TOPCODE record for STOP has to have
LEVADJ 1 for the STOP opcode to translate right -- DPC will be confused
about the stack effect of the RAID opcode)
(PROP DOPVAL STOP)
(FNS T.RAID.GENC)
(PROP TASMFN RAID)
(* * * * * TEST-BUILDING MACRO * * * * *)
(* * globalvar for macros)
(VARS (StackGuardVal 0))
(* * macros for TASMV source)
(PROP TASMFN MakeTest)
(FNS MakeTest.GENC)
(PROP TASMFN StackCheck IfStop ElseStop)
(FNS StackCheck.GENC IfStop.GENC ElseStop.GENC)
(* * fns to use as top-level pseudo-instrs inside MakeTest)
(FNS ShouldWork ShouldUFN ShouldWork.N ShouldUFN.N ShouldT ShouldNIL)
(* * Tamarin function to be called by code generated by ShouldUFN etc)
(VARS CheckUfn)
(* after AOSetup -- (TPUTD (QUOTE CheckUfn)))
(P (TASMV (QUOTE CheckUfn)))
(* * misc macros used by some tests)
(PROP TASMFN V++ V++')
(FNS V++.GENC V++'.GENC)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA ShouldNIL ShouldT ShouldUFN.N ShouldWork.N ShouldUFN
ShouldWork)
(NLAML)
(LAMA])
(* * base for Tamarin Microcode Testing **)
(* * * * * TEMPORARY * * * * *)
(* * need to put NOPs after anything that ufns or FNs -- in particular use NOP? after CONSes
and in ShouldUFN's etc and after all fncalls)
(RPAQQ NOP?CausesNOP T)
(DEFINEQ
(NOP?.GENC
[LAMBDA (instr) (* jmh "21-Jun-86 12:32")
(* * if NOP?CausesNOP then generate a NOP else generate nothing)
(if (AND (BOUNDP (QUOTE NOP?CausesNOP))
NOP?CausesNOP)
then (LET [(label (ASM.NEXTLABEL (QUOTE NOP?]
(LIST (LIST (QUOTE JUMP)
label)
label])
(CONS.GENC
[LAMBDA (instr) (* jmh "21-Jun-86 12:40")
(* * put NOP? after CONSes)
(PUTPROP (QUOTE CONS.1)
(QUOTE TOPCODE)
(GETPROP (QUOTE CONS)
(QUOTE TOPCODE)))
(ASM.EATCODE (LIST (QUOTE (CONS.1))
(QUOTE (NOP?])
)
(PUTPROPS NOP? TASMFN NOP?.GENC)
(PUTPROPS CONS TASMFN CONS.GENC)
(* * * * * ASSEMBLEOPS * * * * *)
(* * AssembleOps setup run)
(DEFINEQ
(AOSetup
[LAMBDA NIL (* jmh " 4-Jun-86 12:37")
(AssembleOps TUTSetup T)
(DoCycle])
)
(RPAQQ TUTSetup ((* * standard initialization of Tam memory is <AssembleOps this T> then <DoCycle>
-- leaves memory clear except as follows, and leaves some Tam internal
registers set up -- still each normal AssembleOps argument has to start with
something like "* tamInit")
(* * note FreeMemIndex is allocation pointer seen in both D-machine and Tamarin
worlds -- AssembleOps passes its value back and forth between worlds -- this
requires that all allocation in the Tamarin from the D-machine side be done
within a call to AssembleOps)
(* * build ufn table at 256, put its addr as value of Tam atom UfnTable -- default
ufn is to STOP, located just after ufn table)
(EvalBytes 0 (AddAtom (QUOTE UfnTable)
(TamRep (QUOTE Int)
256)))
[EvalBytes 0 (LET ((codeAddr (TamRep (QUOTE Code)
512)))
(printout T "loading ufn table..." T)
(for addr from 256 to 511 do (MemoryAccess addr codeAddr T]
(EvalBytes 0 (SETQ tamSetUp.FnBase 512))
* tamSetUp.TrivialFnhdr STOP (* * FrameFlagCode is an atom whose function
definition just RETNPs)
(EvalBytes 0 (AddAtom (QUOTE FrameFlagCode)
NIL
(TamRep (QUOTE Code)
tamSetUp.FnBase)))
* tamSetUp.TrivialFnhdr RETNP (* * IntCode is an atom whose function definition
just RETEIs)
(EvalBytes 0 (AddAtom (QUOTE IntCode)
NIL
(TamRep (QUOTE Code)
tamSetUp.FnBase)))
* tamSetUp.TrivialFnhdr RETEI (* * UndefFn is an atom whose function definition
just RETURNs)
(EvalBytes 0 (AddAtom (QUOTE UndefFn)
NIL
(TamRep (QUOTE Code)
tamSetUp.FnBase)))
* tamSetUp.TrivialFnhdr RETURN (* * PFCode is atom whose function definition is
the dummy page fault routine that just STOPs)
(EvalBytes 0 (AddAtom (QUOTE PFCode)
NIL
(TamRep (QUOTE Code)
tamSetUp.FnBase)))
* tamSetUp.TrivialFnhdr STOP (* * RefCountCode is atom whose function definition
is the dummy refcounting routine that just RETURNs)
(EvalBytes 0 (AddAtom (QUOTE RefCountCode)
NIL
(TamRep (QUOTE Code)
tamSetUp.FnBase)))
* tamSetUp.TrivialFnhdr RETURN (* * add Tam atom TopFrame whose value points to
the top stack frame <initial value for MYCLINK>
-- also allocate some frames)
[EvalBytes 0 (AddAtom (QUOTE TopFrame)
(TamRep (QUOTE Frame)
(InitStackFrames 16]
(* * create atom FreeMemIndex if nec -- AssembleOps will init it)
(AddAtom (QUOTE FreeMemIndex)
(TamRep (QUOTE Int)
0))
(* * code to DoCycle -- first to get the Tam's IREGs set up per the above atoms
then STOP -- should only be necessary when reinitializing the emulator or
rebuilding this memory image)
* TUTSetup.IREGs))
(RPAQQ tamSetUp.TrivialFnhdr (@ tamSetUp.FnBase [EvalBytes 0 (SETQ tamSetUp.StartPC
(TamRep (QUOTE Int)
(TIMES 4
(PLUS
tamSetUp.FnBase 16]
(* * dummy first quadword)
(EvalBytes 16 0)
(* * real 2nd quadword)
(EvalBytes -4 (TamRep (QUOTE Int)
13))
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 (TamRep (QUOTE Code)
tamSetUp.FnBase))
(EvalBytes -4 (TamRep (QUOTE Code)
tamSetUp.FnBase))
(* * 2 quadwords of entry vector)
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 tamSetUp.StartPC)
(EvalBytes -4 tamSetUp.StartPC)
(* * count the header allocated, plus one quadword more for trivial
code that our caller will provide)
(EvalBytes 0 (add tamSetUp.FnBase 20))))
(RPAQQ TUTSetup.IREGs ((* * code to be DoCycle'd to to initialize Tam registers)
@ 0 (* * clear stack pointer for the setup code)
'0 VARX← 0 (* * ireg -> ufn table)
ICONST
[EvalBytes 4 (LOGAND (MASK.1'S 0 24)
(ReadAtom (QUOTE UfnTable)
(QUOTE val]
IREGX←
[CADR (FASSOC (QUOTE ufnbase)
(GETPROP (QUOTE k)
(QUOTE uField]
(* * ireg -> FrameFlagCode)
PCONST
(EvalBytes 4 (ReadAtom (QUOTE FrameFlagCode)
(QUOTE def)))
IREGX←
[CADR (FASSOC (QUOTE frameflagcode)
(GETPROP (QUOTE k)
(QUOTE uField]
(* * ireg -> IntCode)
PCONST
(EvalBytes 4 (ReadAtom (QUOTE IntCode)
(QUOTE def)))
IREGX←
[CADR (FASSOC (QUOTE intcode)
(GETPROP (QUOTE k)
(QUOTE uField]
(* * ireg -> UndefFn)
PCONST
(EvalBytes 4 (ReadAtom (QUOTE UndefFn)
(QUOTE def)))
IREGX←
[CADR (FASSOC (QUOTE undeffn)
(GETPROP (QUOTE k)
(QUOTE uField]
(* * ireg -> PFCode)
PCONST
(EvalBytes 4 (ReadAtom (QUOTE PFCode)
(QUOTE def)))
IREGX←
[CADR (FASSOC (QUOTE pfcode)
(GETPROP (QUOTE k)
(QUOTE uField]
(* * ireg -> RefCountCode)
PCONST
(EvalBytes 4 (ReadAtom (QUOTE RefCountCode)
(QUOTE def)))
IREGX←
[CADR (FASSOC (QUOTE refcountcode)
(GETPROP (QUOTE k)
(QUOTE uField]
(* * done)
STOP))
(* * AssembleOps each-time stuff)
(DEFINEQ
(TPUTD
[LAMBDA (fns) (* jmh "22-Jun-86 00:25")
(* * if fns is an atom take it as singleton list -- ensure all the atoms if fns exist on the Tamarin -- transfer
their TCODE properties to their Tamarin definition cells)
(if (NLISTP fns)
then (SETQ fns (LIST fns)))
(LET (error)
(for x in fns do (if (NOT (LITATOM x))
then (printout T x " not litatom" T)
(SETQ error T)
elseif (NOT (GETPROP x (QUOTE TCODE)))
then (printout T x " has no TCODE property" T)
(SETQ error T)))
(if (NOT error)
then (AssembleOps (for x in fns
collect (BQUOTE (EvalBytes
0
(AddAtom (QUOTE (\, x))
NIL
(AddCode
(QUOTE (\, x])
(TRun
[LAMBDA (list) (* jmh "22-Jun-86 00:02")
(TRunForEffect list)
(DoCycle])
(TRunForEffect
[LAMBDA (list) (* jmh "22-Jun-86 00:27")
(* * if list is an atom take its value -- wherever an atom occurs after a FN0..FN7, replace it with an AddAtom call
-- prepend "@ 0 * TUTinit", postpend "STOP" -- AssembleOps -- DOES NOT TPUTD NOR DoCycle)
(if (NLISTP list)
then (SETQ list (EVAL list)))
[SETQ list (for x in list bind (lastx ← NIL)
collect (PROG1 (if [AND (NLISTP x)
(MEMB lastx
(QUOTE (FN0 FN1 FN2 FN3 FN4 FN5 FN6 FN7]
then [BQUOTE (EvalBytes 3
(AddAtom
(QUOTE (\, x]
else x)
(SETQ lastx x]
[SETQ list (APPEND (QUOTE (@ 0 * TUTInit))
(NCONC1 list (QUOTE STOP]
(AssembleOps list])
(TDo
[LAMBDA (action) (* jmh "25-Jun-86 16:07")
(TRunForEffect (BQUOTE ((EvalBytes 0 (\, action])
)
(RPAQQ TUTInit ((* * every normal AssembleOps input should start with "* this" just after the "@ 0")
(* * clear stack pointer)
'0 VARX← 0 (* * point MYCLINK to stack frames)
PCONST
(EvalBytes 4 (ReadAtom (QUOTE TopFrame)
(QUOTE val)))
MYCLINK←))
(* * add standard testing ufns * *)
(DEFINEQ
(StdUfn
[LAMBDA (opCode nrArgs) (* rtk "25-Jun-86 23:40")
(* * runs in normal context, after AssembleOps is initialized -- give the opcode a ufn that returns a list of the
opcode name and all the ufn's arguments in order -- but the ufn will STOP if it is not called with the right number
of arguments)
(if (NOT (AND opCode (LITATOM opCode)))
then (HELP "opcode isn't litatom" opCode))
(if (NOT (NUMBERP nrArgs))
then (HELP "nrArgs not number" nrArgs))
(LET [(ufnName (PACK* opCode (QUOTE .StdUfn]
[SET ufnName (BQUOTE ((LAMBDA: (\, ufnName)
(A1 A2 A3 A4 A5 A6 A7))
(VARS: A1 A2 A3 A4 A5 A6 A7)
CODE:
(STOP)
(\, (PACK* (QUOTE ENTRY)
nrArgs))
(ACONST (\, opCode))
[\,@ (for i from 1 to nrArgs
collect (LIST (QUOTE VAR)
(PACK* (QUOTE A)
i]
('NIL)
[\,@ (for i from 1 to nrArgs collect (QUOTE (CONS]
(CONS)
(RETURN]
(TASMV ufnName)
(TDo (BQUOTE (AddUfns (QUOTE (((\, opCode)
(\, ufnName])
)
(RPAQQ CONS.TUFN ((LAMBDA: CONS.TUFN (a b))
(VARS: a b ptr)
CODE:
(STOP)
ENTRY2
(* get FreeMemIndex and inc it)
(ACONST FreeMemIndex)
(COPY)
(GETBASEPTR.N 1)
(VAR← ptr)
(SIC 2)
(ADDBASE)
(PUTBASEPTR.N 1)
(* load the cons cell)
(VAR ptr)
(VAR a)
(PUTBASEPTR.N 0)
(VAR b)
(PUTBASEPTR.N 1)
(* return a ConsP)
(SIC 4)
(SETSUBTYPE)
(RETURN)))
(* after AOSetup -- (TDo (QUOTE (AddUfns (QUOTE ((CONS CONS.TUFN)))))))
(TASMV (QUOTE CONS.TUFN))
(* * * * * MACHINE DEFINITION * * * * *)
(* * constants)
(DECLARE: EVAL@COMPILE
(RPAQ T.MaxInt (SUB1 (LLSH 1 29)))
(RPAQ T.MinInt (MINUS (LLSH 1 29)))
[CONSTANTS (T.MaxInt (SUB1 (LLSH 1 29)))
(T.MinInt (MINUS (LLSH 1 29]
)
(* * cause Lisp "(STOP)" to turn into D-machine RAID opcode which then translates to Tamarin
STOP opcode -- the TOPCODE record for STOP has to have LEVADJ 1 for the STOP opcode to
translate right -- DPC will be confused about the stack effect of the RAID opcode)
(PUTPROPS STOP DOPVAL (0 RAID))
(DEFINEQ
(T.RAID.GENC
[LAMBDA (INSTR) (* jmh "16-May-86 15:55")
(LIST (LIST (QUOTE STOP])
)
(PUTPROPS RAID TASMFN T.RAID.GENC)
(* * * * * TEST-BUILDING MACRO * * * * *)
(* * globalvar for macros)
(RPAQQ StackGuardVal 0)
(* * macros for TASMV source)
(PUTPROPS MakeTest TASMFN MakeTest.GENC)
(DEFINEQ
(MakeTest.GENC
[LAMBDA (wholeForm) (* jmh " 5-Jun-86 15:37")
(* * <MakeTest bindings %. forms> assembles the result of joining the evals of all the forms <evaled inside a LET
using the bindings> -- NOTE these forms are EVALed, not compiled immediately, and that they return lists of
instructions)
(ASM.EATCODE (EVAL (BQUOTE (LET (\, (CADR wholeForm))
(for form in (QUOTE (\, (CDDR wholeForm)))
join (if (AND (LISTP form)
(NEQ (CAR form)
(QUOTE *)))
then (EVAL (COPYALL form])
)
(PUTPROPS StackCheck TASMFN StackCheck.GENC)
(PUTPROPS IfStop TASMFN IfStop.GENC)
(PUTPROPS ElseStop TASMFN ElseStop.GENC)
(DEFINEQ
(StackCheck.GENC
[LAMBDA (wholeForm) (* jmh " 4-Jun-86 17:10")
(* * <CDR wholeForm> is a list of instrs -- assemble the whole of them wrapped in a stack check)
(LET [(guard (PROG1 StackGuardVal (add StackGuardVal 1]
[ASM.EATCODE (BQUOTE ((GCONST (\, guard]
(ASM.EATCODE (CDR wholeForm))
(ASM.EATCODE (BQUOTE ((GCONST (\, guard))
(EQ)
(ElseStop])
(IfStop.GENC
[LAMBDA NIL (* jmh " 4-Jun-86 17:28")
(* * return code which will STOP if TOS is true <popping in any case>)
(LET [(label (ASM.NEXTLABEL (QUOTE IfStop]
(ASM.EATCODE (BQUOTE ((FJUMP (\, label))
(STOP)
(\, label])
(ElseStop.GENC
[LAMBDA NIL (* jmh " 4-Jun-86 17:28")
(* * assemble code which will STOP if TOS is false <popping in any case>)
(LET [(label (ASM.NEXTLABEL (QUOTE ElseStop]
(ASM.EATCODE (BQUOTE ((TJUMP (\, label))
(STOP)
(\, label])
)
(* * fns to use as top-level pseudo-instrs inside MakeTest)
(DEFINEQ
(ShouldWork
[NLAMBDA argLists (* jmh "21-Jun-86 15:51")
(* * fn to use inside MakeTest to make test cases when <1> it is a vanilla 1-byte opcode <2> the arguments can be
computed at D-machine compile time <3> you do not expect to UFN)
(* * implicit arguments -- testOpCode = the atom which is the name of the opcode being tested -- equivFn = a
function with the same semantics as that opcode)
(* * argLists is a list of argument lists, one per test case -- the argument lists are not EVALed, but the
individual arguments are)
(* * for each arg, the GCONST macro is used to generate instructions to make that value on the Tamarin)
(* * returns list of instructions -- for each test case <1> generate each arg in order <2> the opcode <3> a GCONST
for the result of applying the equivFn to the args <in the D-machine> <4> EQ <5> STOP-if-false, <6> all wrapped
inside a stack check)
(DECLARE (USEDFREE testOpCode equivFn))
(for args in argLists bind evaledArgs
collect (SETQ evaledArgs (for arg in args collect (EVAL arg)))
(BQUOTE (StackCheck [\,@ (for arg in evaledArgs
collect (BQUOTE (GCONST (\, arg]
((\, testOpCode))
(NOP?)
(GCONST (\, (APPLY equivFn evaledArgs)))
(EQ)
(ElseStop])
(ShouldUFN
[NLAMBDA argLists (* jmh "21-Jun-86 15:58")
(* * fn to use inside MakeTest to make test cases when <1> it is a 1-byte opcode <2> you DO expect to UFN <3> the
UFN will return the opcode name)
(* * implicit arguments -- testOpCode = the atom which is the name of the opcode being tested -- this is also the
Tamarin atom the UFN is expected to return)
(* * argLists is a list of argument lists, one per test case -- the argument lists are not EVALed, but the
individual arguments are)
(* * IF an individual arg is not a LISTP THEN the GCONST macro is used to generate instructions to make that value
on the Tamarin -- ELSE it is the Tamarin code to use)
(* * enough of the pvars arg1 arg2 arg3 must be declared for the number of arguments the ufn will see)
(* * returns list of instructions -- for each test <1> case generate each arg in order <2> the opcode <3> a GCONST
for the opcode name <4> EQ <5> STOP-if-false, <6> all wrapped inside a stack check)
(DECLARE (USEDFREE testOpCode))
(for args in argLists bind evaledArgs
collect (SETQ evaledArgs (for arg in args collect (EVAL arg)))
(BQUOTE (StackCheck
[\,@ (for arg in evaledArgs as argNr from 1
join (APPEND [if (LISTP arg)
then arg
else (BQUOTE ((GCONST (\, arg]
(BQUOTE ((VAR←(\, (PACK* (QUOTE arg)
argNr]
((\, testOpCode))
(NOP?)
(ACONST (\, testOpCode))
[\,@ (for arg in evaledArgs as argNr from 1
collect (BQUOTE (VAR (\, (PACK* (QUOTE arg)
argNr]
(FN (\, (IPLUS 2 (LENGTH evaledArgs)))
CheckUfn)
(POP])
(ShouldWork.N
[NLAMBDA argLists (* jmh "21-Jun-86 15:55")
(* * fn to use inside MakeTest to make test cases when <1> the opcode takes an in-stream argument <2> the arguments
can be computed at D-machine compile time <3> you do not expect to UFN)
(* * implicit arguments -- testOpCode = the atom which is the name of the opcode being tested -- equivFn = a
function with the same semantics as that opcode)
(* * argLists is a list of argument lists, one per test case -- the argument lists are not EVALed, but the
individual arguments are)
(* * the first argument is the in-stream argument for the opcode <the .N> -- for the remainder, the GCONST macro is
used to generate instructions to make that value on the Tamarin)
(* * returns list of instructions -- for each test case <1> generate the args in order <2> the opcode with its
in-stream argument <3> a GCONST for the result of applying the equivFn to ALL the args <in-stream argument first>
<4> EQ <5> STOP-if-false, <6> all wrapped inside a stack check)
(DECLARE (USEDFREE testOpCode equivFn))
(for args in argLists bind evaledArgs
collect (SETQ evaledArgs (for arg in args collect (EVAL arg)))
(BQUOTE (StackCheck [\,@ (for arg in (CDR evaledArgs)
collect (BQUOTE (GCONST (\, arg]
((\, testOpCode)
(\, (CAR evaledArgs)))
(NOP?)
(GCONST (\, (APPLY equivFn evaledArgs)))
(EQ)
(ElseStop])
(ShouldUFN.N
[NLAMBDA argLists (* jmh "21-Jun-86 16:03")
(* * fn to use inside MakeTest to make test cases when <1> the opcode takes an in-stream argument <2> you DO expect
to UFN <3> the UFN will return the opcode name)
(* * implicit arguments -- testOpCode = the atom which is the name of the opcode being tested -- this is also the
Tamarin atom the UFN is expected to return)
(* * argLists is a list of argument lists, one per test case -- the argument lists are not EVALed, but the
individual arguments are)
(* * the first argument is the in-stream argument for the opcode <the .N> -- and for the remainder: IF it is not a
LISTP THEN the GCONST macro is used to generate instructions to make that value on the Tamarin -- ELSE it is the
Tamarin code to use)
(* * enough of the pvars arg1 arg2 arg3 must be declared for the number of arguments the ufn will see)
(* * returns list of instructions -- for each test case <1> generate the args in order <2> the opcode with its
in-stream argument <3> a GCONST for the opcode name <4> EQ <5> STOP-if-false, <6> all wrapped inside a stack check)
(DECLARE (USEDFREE testOpCode))
(for args in argLists bind evaledArgs
collect (SETQ evaledArgs (for arg in args collect (EVAL arg)))
(BQUOTE (StackCheck
[\,@ (for arg in (CDR evaledArgs) as argNr from 1
join (APPEND [if (LISTP arg)
then arg
else (BQUOTE ((GCONST (\, arg]
(BQUOTE ((VAR←(\, (PACK* (QUOTE arg)
argNr]
((\, testOpCode)
(\, (CAR evaledArgs)))
(NOP?)
(ACONST (\, testOpCode))
[\,@ (for arg in (CDR evaledArgs) as argNr from 1
collect (BQUOTE (VAR (\, (PACK* (QUOTE arg)
argNr]
(GCONST (\, (CAR evaledArgs)))
(FN (\, (IPLUS 2 (LENGTH evaledArgs)))
CheckUfn)
(POP])
(ShouldT
[NLAMBDA argLists (* jmh " 5-Jun-86 15:33")
(* * fn to use inside MakeTest to make test cases when <1> it is a 1-byte opcode <2> the opcode is expected to
return some True value)
(* * implicit arguments -- testOpCode = the atom which is the name of the opcode being tested)
(* * argLists is a list of argument lists, one per test case -- these argument lists are not EVALed, but the
individual arguments are)
(* * IF an arg for a test case is not a LISTP THEN the GCONST macro is used to generate instructions to push that
value in the Tamarin ELSE the arg is the Tamarin code to use)
(* * returns list of instructions -- for each test case <1> generate each arg in order <2> the opcode <3>
STOP-if-false, <6> all wrapped inside a stack check)
(DECLARE (USEDFREE testOpCode))
(LET (evaledArgs)
(for args in argLists
join (SETQ evaledArgs (for arg in args collect (EVAL arg)))
(LIST (CONS (QUOTE StackCheck)
(NCONC [for arg in evaledArgs
join (if (LISTP arg)
then arg
else (LIST (LIST (QUOTE GCONST)
arg]
(LIST (LIST testOpCode)
(QUOTE (ElseStop])
(ShouldNIL
[NLAMBDA argLists (* jmh " 5-Jun-86 15:33")
(* * fn to use inside MakeTest to make test cases when <1> it is a 1-byte opcode <2> the opcode is expected to
return NIL)
(* * implicit arguments -- testOpCode = the atom which is the name of the opcode being tested)
(* * argLists is a list of argument lists, one per test case -- these argument lists are not EVALed, but the
individual arguments are)
(* * IF an arg for a test case is not a LISTP THEN the GCONST macro is used to generate instructions to push that
value in the Tamarin ELSE the arg is the Tamarin code to use)
(* * returns list of instructions -- for each test case <1> generate each arg in order <2> the opcode <3>
STOP-if-true, <6> all wrapped inside a stack check)
(DECLARE (USEDFREE testOpCode))
(LET (evaledArgs)
(for args in argLists
join (SETQ evaledArgs (for arg in args collect (EVAL arg)))
(LIST (CONS (QUOTE StackCheck)
(NCONC [for arg in evaledArgs
join (if (LISTP arg)
then arg
else (LIST (LIST (QUOTE GCONST)
arg]
(LIST (LIST testOpCode)
(QUOTE (IfStop])
)
(* * Tamarin function to be called by code generated by ShouldUFN etc)
(RPAQQ CheckUfn ((LAMBDA: CheckUfn (result opcode arg1 arg2 arg3))
(VARS: result opcode arg1 arg2 arg3)
CODE:
(* * <CheckUfn ufnResult opCode args..> returns iff ufnResult is list of opCode
then args, else STOPs -- returns ufnResult for lack of anything better -- 0..3
args)
(* bad #args entry point)
(STOP)
(* * * * * enter with 0..3 of arg1..arg3 -- 1st check that result list is of
correct length, then go check all its elements * * * * *)
(* * result = opcode arg1 arg2 arg3)
ENTRY5
(VAR result)
(CDR)
(CDR)
(CDR)
(COPY)
(FJUMP ENTRY5bad)
(CDR)
(FJUMP 3args)
ENTRY5bad
(STOP)
(* * result = opcode arg1 arg2)
ENTRY4
(VAR result)
(CDR)
(CDR)
(COPY)
(FJUMP ENTRY4bad)
(CDR)
(FJUMP 2args)
ENTRY4bad
(STOP)
(* * result = opcode arg1)
ENTRY3
(VAR result)
(CDR)
(COPY)
(FJUMP ENTRY3bad)
(CDR)
(FJUMP 1args)
ENTRY3bad
(STOP)
(* * result = opcode)
ENTRY2
(VAR result)
(COPY)
(FJUMP ENTRY2bad)
(CDR)
(FJUMP 0args)
ENTRY2bad
(STOP)
(* * * * * check arg3 .. arg1 then opcode * * * * *)
(* * arg3)
3args
(VAR result)
(CDR)
(CDR)
(CDR)
(CAR)
(VAR arg3)
(EQ)
(ElseStop)
(* * arg2)
2args
(VAR result)
(CDR)
(CDR)
(CAR)
(VAR arg2)
(EQ)
(ElseStop)
(* * arg1)
1args
(VAR result)
(CDR)
(CAR)
(VAR arg1)
(EQ)
(ElseStop)
(* * arg3)
0args
(VAR result)
(CAR)
(VAR opcode)
(EQ)
(ElseStop)
(* * * * * return result for lack of anything better * * * * *)
(VAR result)
(RETURN)))
(* after AOSetup -- (TPUTD (QUOTE CheckUfn)))
(TASMV (QUOTE CheckUfn))
(* * misc macros used by some tests)
(PUTPROPS V++ TASMFN V++.GENC)
(PUTPROPS V++' TASMFN V++'.GENC)
(DEFINEQ
(V++.GENC
[LAMBDA (INSTR) (* jmh " 6-Jun-86 12:56")
(BQUOTE ((VAR (\, (CADR INSTR)))
(COPY)
('1)
(PLUS)
(VAR←↑(\, (CADR INSTR])
(V++'.GENC
[LAMBDA (INSTR) (* jmh " 6-Jun-86 12:56")
(BQUOTE ((VAR (\, (CADR INSTR)))
(COPY)
('1)
(PLUS)
(VAR←(\, (CADR INSTR)))
(POP])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA ShouldNIL ShouldT ShouldUFN.N ShouldWork.N ShouldUFN ShouldWork)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS TUTBASE COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2859 3626 (NOP?.GENC 2869 . 3266) (CONS.GENC 3268 . 3624)) (3777 3944 (AOSetup 3787 .
3942)) (9306 11480 (TPUTD 9316 . 10265) (TRun 10267 . 10415) (TRunForEffect 10417 . 11311) (TDo 11313
. 11478)) (11800 13091 (StdUfn 11810 . 13089)) (14232 14393 (T.RAID.GENC 14242 . 14391)) (14626 15320
(MakeTest.GENC 14636 . 15318)) (15459 16656 (StackCheck.GENC 15469 . 15961) (IfStop.GENC 15963 .
16304) (ElseStop.GENC 16306 . 16654)) (16723 26957 (ShouldWork 16733 . 18249) (ShouldUFN 18251 . 20216
) (ShouldWork.N 20218 . 21909) (ShouldUFN.N 21911 . 24108) (ShouldT 24110 . 25538) (ShouldNIL 25540 .
26955)) (29049 29555 (V++.GENC 29059 . 29295) (V++'.GENC 29297 . 29553)))))
STOP