(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-Nov-87 17:41:49" {PHYLUM}<CTAMARIN>EMULATOR>TESTOPS.;49 81471
changes to%: (VARS applycode applyufn)
previous date%: "12-Nov-87 16:42:00" {PHYLUM}<CTAMARIN>EMULATOR>TESTOPS.;48)
(* "
Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TESTOPSCOMS)
(RPAQQ TESTOPSCOMS ((* * CMOS Tests)
(* ;; "Older Format Tests (May not be compatable)")
(VARS test1 test3 tamtak dumploadtest testfnops refcounttest ufn1test irqouttest
irqtest)
(* ;; "New Format Tests")
(VARS fulltest)
(VARS shifttest shiftcode shiftufns)
(VARS binoptest binopcode binopufns)
(VARS typetest typecode typeufns)
(VARS eqtest eqcode equfns)
(VARS frameflagstest frameflagscode frameflagufns)
(VARS vartest varcode varufns)
(VARS tostest toscode tosufns)
(VARS listtest listcode listufns)
(VARS ptrtest ptrcode ptrufns)
(VARS cstoretest cstorecode cstoreufns)
(* ;; " Not yet in fulltest")
(VARS closuretest closurecode closureufns)
(VARS undefntest undefncode undefnufns)
(VARS gctest gccode gcufns)
(VARS constest conscode consufns)
(VARS slowrettest slowretcode slowretufns)
(VARS jumptest jumpcode)
(VARS applytest applycode applyufn)
(VARS fntest fncode fnufn)
(* * Un Modified for CMOS)
(VARS simtest simtracetest)
(VARS testgregops testcarcdrops testconstops2 testshiftops teststackops
testconstops testops testops2 testovarops testash)
(* * Variable referencing)
(VARS testvarops testgvarops fvartest)
(* * Jump Tests)
(VARS testjumpops smalljumps jumperror tfsmalljumps negjumpx negjumpxx ibuftest)
(* * Function Call)
(VARS fntest undefntest applytest fnops ufn1dtest ufn2test frameadjust ufndump)
(* * Interrupt Tests)
(VARS irqenbtest)
(* * Virtual Memory Tests)
(VARS vmtest vmtest2 vmtest3)
(* * Special Opcodes)
(VARS testwoct)
(* * Initialization)
(VARS tamSetUp tamInit)
(* * Special Loadups)
(VARS dotak dotak2)
(FNS Testfn tak)))
(* * CMOS Tests)
(* ;; "Older Format Tests (May not be compatable)")
(RPAQQ test1
(@ 0 %'T %'1 SICX 2 PLUS ICONST 1 2 3 4 GVAR (EvalBytes 4 (AddAtom 'A (TamRep 'Int 3)))
PLUS SICXX 1 2 JUMPX 3 %'1 %'1 %'1 PLUS %'T COPY FJUMPX 3 TJUMPX 7 ICONST 33 67 101 135
PLUS STOP NJUMPX 34))
(RPAQQ test3
(@ 0 8 9 10 11 12 13 14 15 15 14 13 12 11 10 9 8 0 STOP))
(RPAQQ tamtak (@ 0 (EvalBytes 5 (MakePConst (InitStackFrames 14)))
MYCLINK← SICX 9 SICX 6 SICX 3 FN3 (EvalBytes 4 (AddAtom 'tak))
STOP
(EvalBytes 0 (AddFnHeader 'tak (NextFnAddr)))
VAR0 COPY VAR1 GREATERP TJUMP2 VAR2 RETURN SUBX 1 VAR1 VAR2 FN3
(EvalBytes 4 (AddAtom 'tak))
VAR1 SUBX 1 VAR2 VAR0 FN3 (EvalBytes 4 (AddAtom 'tak))
VAR2 SUBX 1 VAR0 VAR1 FN3 (EvalBytes 4 (AddAtom 'tak))
VAR2←↑ VAR1←↑ VAR0← NJUMPX 40 NOP RETURN STOP))
(RPAQQ dumploadtest (@ 0 (EvalBytes 5 (MakePConst (InitStackFrames 8)))
MYCLINK← SICX 5 FN0 (EvalBytes 4 (AddAtom 'fn))
STOP STOP (EvalBytes 0 (AddFnHeader 'fn))
MYCLINK %'1 RETURN))
(RPAQQ testfnops (@ 0 %'0 VARX← 0 (EvalBytes 5 (MakePConst (InitStackFrames 8)))
MYCLINK← SICX 1 FN1 (EvalBytes 4 (AddAtom 'fn))
STOP STOP (EvalBytes 0 (AddFnHeader 'fn))
VAR0 COPY %'0 EQ TJUMPX 10 SUBX 1 FN1 (EvalBytes 4 (AddAtom 'fn))
ADDX 1 RETURN MYCLINK SICX 255 RETURN))
(RPAQQ refcounttest (@ 0 (EvalBytes 0 (AddAtom 'Ptr1 (TamRep 1)
NIL NIL 2))
SCONST
(EvalBytes 4 (AddAtom 'A (TamRep 3)
NIL NIL 4))
GVAR←
[EvalBytes 4 (AddAtom 'B (TamRep 'Symbol (AtomIndex 'Ptr1]
GVAR
(EvalBytes 4 (AddAtom 'B))
SICX 2 STOP))
(RPAQQ ufn1test (@ 0 %'0 (EvalBytes 5 (MakePConst (InitStackFrames 8)))
MYCLINK←
(EvalBytes 5 (MakePConst (TamRep 'Ptr FreeMemIndex)))
IREGX←
(LOGAND [CADR (FASSOC 'UfnBase (GETPROP 'k 'uField]
63)
(EvalBytes 5 (MakePConst (TamRep 'Code 64)))
PUTBASEPTR.N NEG %'T NEG %'0 STOP STOP (EvalBytes 0 (AddFnHeader 'ufn 64))
VAR0 %'UNBOUND RETURN STOP))
(RPAQQ irqouttest
(@ 0 %'1 SICX 2 PLUS SETOUTPUTINT %'1 PLUS CLROUTPUTINT %'1 PLUS SETOUTPUTINT %'1 PLUS
CLROUTPUTINT %'1 PLUS SETOUTPUTINT %'1 PLUS CLROUTPUTINT %'1 PLUS SETOUTPUTINT %'1 PLUS
CLROUTPUTINT STOP))
(RPAQQ irqtest (@ 0 %'0 VARX← 0 (EvalBytes 5 (MakePConst (InitStackFrames 8)))
MYCLINK←
[EvalBytes 5 (MakePConst (AddAtom 'Irq1Fn]
GETBASEPTR.N
(UProp 'DefCellOffset 'k2)
IREGX←
(LOGAND (UProp 'Irq1Code 'k)
63)
[EvalBytes 5 (MakePConst (AddAtom 'Irq2Fn]
GETBASEPTR.N
(UProp 'DefCellOffset 'k2)
IREGX←
(LOGAND (UProp 'Irq2Code 'k)
63)
ENBINT SICX 0 %'1 PLUS NJUMPX 4 STOP STOP (EvalBytes 0 (AddFnHeader 'Irq1Fn (
NextFnAddr
)))
%'1 RETEI (EvalBytes 0 (AddFnHeader 'Irq2Fn (NextFnAddr)))
SICX 2 RETEI))
(* ;; "New Format Tests")
(RPAQQ fulltest (@ 0 (* * * * * * * * * * * * Micro Test * * * * * * * * * * * * *)
(InitClink 8)
(UfnBase)
* ptrcode * cstorecode (JumpNewPage)
* listcode (JumpNewPage)
* frameflagscode * toscode (JumpNewPage)
* varcode (JumpNewPage)
* binopcode (JumpNewPage)
* eqcode (JumpNewPage)
* typecode (JumpNewPage)
* shiftcode STOP * shiftufns * binopufns * typeufns * equfns * varufns (
JumpNewPage
)
* frameflagufns * tosufns * listufns * ptrufns * cstoreufns))
(RPAQQ shifttest (@ 0 (InitClink 8)
(UfnBase)
* shiftcode STOP * shiftufns))
(RPAQQ shiftcode ((* * * * * * * * * * * * Shift Tests * * * * * * * * * * * * *)
(UfnEntry '(DLLSH.N ALSH LRSH.N LLSH.N DLLSH LLSH LRSH))
(FRAID (DLLSH.N 16 287454020 1432778632)
860116326)
(FRAID (DLLSH.N 16 DLLSH.N 1432778632)
DLLSH.N-UFN)
(FRAID (DLLSH 287454020 1432778632 16)
860116326)
(FRAID (DLLSH DLLSH 1432778632 16)
DLLSH-UFN)
(FRAID (DLLSH 287454020 1432778632 32)
1432778632)
(FRAID (DLLSH 287454020 1432778632 33)
DLLSH-UFN)
(FRAID (DLLSH 287454020 1432778632 -1)
DLLSH-UFN)
(FRAID (DLLSH 287454020 1432778632 0)
287454020)
(FRAID (LRSH 2 1)
1)
(FRAID (LRSH 4294967295 1)
2147483647)
(FRAID (LRSH 21845 3)
2730)
(FRAID (LRSH LRSH.N 2)
LRSH-UFN)
(FRAID (LRSH 4294967295 32)
0)
(FRAID (LRSH 4294967295 33)
LRSH-UFN)
(FRAID (LRSH 0 -1)
LRSH-UFN)
(FRAID (LLSH 1 1)
2)
(FRAID (LLSH 1 0)
1)
(FRAID (LLSH -2 2)
-8)
(FRAID (LLSH LLSH 2)
LLSH-UFN)
(FRAID (LLSH 4294967295 32)
0)
(FRAID (LLSH 4294967295 33)
LLSH-UFN)
(FRAID (LLSH 0 -1)
LLSH-UFN)
(FRAID (ALSH -1 1)
-2)
(FRAID (ALSH 2 1)
4)
(FRAID (ALSH 4 -1)
2)
(FRAID (ALSH 1 0)
ALSH-UFN)
(FRAID (ALSH -4 -1)
-2)
(FRAID (ALSH 1073741823 2)
ALSH-UFN)
(FRAID (ALSH 2415919103 2)
ALSH-UFN)
(FRAID (ALSH 2415919103 33)
ALSH-UFN)
(FRAID (ALSH 2415919103 -33)
ALSH-UFN)
(FRAID (ALSH 1 32)
ALSH-UFN)
(FRAID (ALSH 0 32)
0)
(FRAID (ALSH 1 31)
ALSH-UFN)
(FRAID (ALSH 1 -31)
0)
(FRAID (ALSH 1 -32)
0)
(FRAID (ALSH 1 -33)
ALSH-UFN)
(FRAID (ALSH 2147483648 -32)
-1)
(FRAID (LLSH.N 1 1)
2)
(FRAID (LLSH.N 0 1)
1)
(FRAID (LLSH.N 2 -2)
-8)
(FRAID (LLSH.N 2 LLSH.N)
LLSH.N-UFN)
(FRAID (LRSH.N 1 2)
1)
(FRAID (LRSH.N 1 4294967295)
2147483647)
(FRAID (LRSH.N 3 21845)
2730)
(FRAID (LRSH.N 2 LRSH.N)
LRSH.N-UFN)))
(RPAQQ shiftufns [[AddFn '(ALSH ((RETURN ALSH-UFN]
[AddFn '(LLSH.N ((RETURN LLSH.N-UFN]
[AddFn '(LRSH.N ((RETURN LRSH.N-UFN]
[AddFn '(DLLSH.N ((RETURN DLLSH.N-UFN]
[AddFn '(DLLSH ((RETURN DLLSH-UFN]
[AddFn '(LLSH ((RETURN LLSH-UFN]
(AddFn '(LRSH ((RETURN LRSH-UFN])
(RPAQQ binoptest (@ 0 (InitClink 8)
(UfnBase)
* binopcode STOP * binopufns))
(RPAQQ binopcode ((FRAID (FRAID (ADC T 4 5)
10)
NIL)
(FRAID (FRAID (ADC NIL 6 7)
13)
NIL)
(FRAID (FRAID (ADC NIL 4294967280 7)
4294967287)
NIL)
(FRAID (FRAID (ADC NIL 4294967280 17)
1)
T)
(FRAID (FRAID (SBC T 7 4)
3)
T)
(FRAID (FRAID (SBC NIL 8 5)
2)
T)
(FRAID (FRAID (SBC NIL 5 8)
-4)
NIL)
(UfnEntry '(PRIORITY LOGAND LOGOR LOGXOR LOGNOT PLUS DIFFERENCE NEG ADDX SUBX))
(FRAID (LOGNOT 4294967295)
0)
(FRAID (LOGNOT 1431677610)
2863289685)
(FRAID (LOGNOT a)
LOGNOT-UFN)
(FRAID (PRIORITY -1)
0)
(FRAID (PRIORITY 1879048192)
1)
(FRAID (PRIORITY 1)
31)
(FRAID (PRIORITY 0)
32)
(FRAID (PRIORITY a)
PRIORITY-UFN)
(FRAID (LOGAND 2863289685 4294967295)
2863289685)
(FRAID (LOGAND 0 4294967295)
0)
(FRAID (LOGAND 4294967295 1431677610)
1431677610)
(FRAID (LOGAND a 1431677610)
LOGAND-UFN)
(FRAID (LOGAND 0 a)
LOGAND-UFN)
(FRAID (LOGAND (TamRep 'Code 1)
0)
LOGAND-UFN)
(FRAID (LOGOR 2863289685 4294967295)
4294967295)
(FRAID (LOGOR 4294967295 0)
4294967295)
(FRAID (LOGOR 1431633920 43690)
1431677610)
(FRAID (LOGOR 0 a)
LOGOR-UFN)
(FRAID (LOGOR (TamRep 'Code 1)
0)
LOGOR-UFN)
(FRAID (LOGXOR 2863289685 4294967295)
1431677610)
(FRAID (LOGXOR 4294967295 0)
4294967295)
(FRAID (LOGXOR 1431633920 11512490)
1442491050)
(FRAID (LOGXOR 0 a)
LOGXOR-UFN)
(FRAID (LOGXOR (TamRep 'Code 1)
0)
LOGXOR-UFN)
(FRAID (ADDX 1 2)
3)
(FRAID (ADDX 4 -2)
2)
(FRAID (ADDX 4 ADDX)
ADDX-UFN)
(FRAID (ADDX 4 2147483645)
ADDX-UFN)
(FRAID (SUBX 1 2)
1)
(FRAID (SUBX 4 2)
-2)
(FRAID (SUBX 4 SUBX)
SUBX-UFN)
(FRAID (SUBX 4 -2147483645)
SUBX-UFN)
(FRAID (NEG 2147483648)
NEG-UFN)
(FRAID (NEG 1)
-1)
(FRAID (NEG -1)
1)
(FRAID (NEG 2147483647)
-2147483647)
(FRAID (NEG -2147483647)
2147483647)
(FRAID (NEG 2147483648)
NEG-UFN)
(JumpNewPage)
(FRAID (PLUS 1 2)
3)
(FRAID (PLUS -3 1)
-2)
(FRAID (PLUS -1 1)
0)
(FRAID (PLUS 2147483647 1)
PLUS-UFN)
(FRAID (PLUS 1 2147483647)
PLUS-UFN)
(FRAID (PLUS 2147483646 1)
2147483647)
(FRAID (PLUS -2147483647 -1)
-2147483648)
(FRAID (PLUS -2147483648 1)
-2147483647)
(FRAID (DIFFERENCE 0 2147483648)
DIFFERENCE-UFN)
(FRAID (DIFFERENCE 2 1)
1)
(FRAID (DIFFERENCE 1 0)
1)
(FRAID (DIFFERENCE 1 2)
-1)
(FRAID (DIFFERENCE 2147483647 1)
2147483646)
(FRAID (DIFFERENCE 2147483648 -1)
-2147483647)
(FRAID (DIFFERENCE 2147483648 1)
DIFFERENCE-UFN)
(FRAID (DIFFERENCE 1 2147483647)
-2147483646)
(FRAID (DIFFERENCE -2147483647 1)
2147483648)
(FRAID (DIFFERENCE 2147483646 -1)
2147483647)
(FRAID (DIFFERENCE 2147483647 -1)
DIFFERENCE-UFN)))
(RPAQQ binopufns [[AddFn '(PLUS ((RETURN PLUS-UFN]
[AddFn '(DIFFERENCE ((RETURN DIFFERENCE-UFN]
[AddFn '(NEG ((RETURN NEG-UFN]
[AddFn '(ADDX ((RETURN ADDX-UFN]
[AddFn '(SUBX ((RETURN SUBX-UFN]
[AddFn '(LOGNOT ((RETURN LOGNOT-UFN]
[AddFn '(LOGXOR ((RETURN LOGXOR-UFN]
[AddFn '(LOGOR ((RETURN LOGOR-UFN]
[AddFn '(LOGAND ((RETURN LOGAND-UFN]
(AddFn '(PRIORITY ((RETURN PRIORITY-UFN])
(RPAQQ typetest (@ 0 * typecode STOP * typeufns))
(RPAQQ typecode ((FRAID (FIXP 1)
T)
(FRAID (FIXP T)
NIL)
(FRAID (FLOATP (TamRep 'Float 5))
T)
(FRAID (FLOATP 1)
NIL)
(FRAID (POINTERP (TamRep 'List))
T)
(FRAID (POINTERP (TamRep 'Code))
T)
(FRAID (POINTERP 1)
NIL)
(FRAID (IMMEDIATEP (TamRep 'Unbound))
T)
(FRAID (IMMEDIATEP (TamRep 'Cons 5))
NIL)
(FRAID (CONSP (TamRep 'Cons 6))
T)
(FRAID (CONSP (TamRep 'SmallCons 7))
T)
(FRAID (SYMBOLP (AddAtom 'Var1))
T)
(FRAID (SYMBOLP (TamRep 'NoRcSymbol 10))
T)
(FRAID (SYMBOLP (TamRep 'Cons 10))
NIL)
(FRAID (CONSP T)
NIL)
(FRAID (GETTYPEBITS T)
(TamTagRep 'Symbol))
[FRAID (SETSUBTYPE (TamTagRep 'Symbol)
(TamTagRep 'List))
(TamRep 'List (TamTagRep 'Symbol]
(FRAID (SUBTYPEP.N (TamTagRep 'Code)
(TamRep 'Code))
T)
(FRAID (SUBTYPEP.N (TamTagRep 'Code)
T)
NIL)
(FRAID (SUBTYPEP.N (TamTagRep 'Symbol)
NIL)
T)
(FRAID (SUBTYPEP.N (ADD1 (TamTagRep 'Symbol))
NIL)
NIL)
(FRAID (GETPTRBITS (TamRep 4279383040))
118633472)
(FRAID (SETTYPE.N (TamTagRep 'Symbol)
4660)
(TamRep 'Imm 4660))
(FRAID (SETSUBTYPE 4660 (TamTagRep 'Code))
(TamRep 'Code 4660))))
(RPAQQ typeufns (STOP))
(RPAQQ eqtest (@ 0 (InitClink 8)
(UfnBase)
* eqcode STOP * equfns))
(RPAQQ eqcode ((UfnEntry '(EQL EQUAL GREATERP))
(FRAID (GREATERP 3 2)
T)
(FRAID (GREATERP 3 3)
NIL)
(FRAID (GREATERP 2147483647 2147483648)
T)
(FRAID (GREATERP 2147483647 2147483646)
T)
(FRAID (GREATERP 2147483647 -1)
T)
(FRAID (GREATERP 2147483648 2147483647)
NIL)
(FRAID (GREATERP 2147483648 2147483649)
NIL)
(FRAID (GREATERP 2147483649 2147483648)
T)
(FRAID (GREATERP 0 -1)
T)
(FRAID (GREATERP -1 0)
NIL)
(FRAID (GREATERP -2 -1)
NIL)
(FRAID (GREATERP -1 -2)
T)
(FRAID (GREATERP a 0)
GREATERP-UFN)
(FRAID (GREATERP 1 (TamRep 'Float 1))
GREATERP-UFN)
(FRAID (EQ a b)
NIL)
(FRAID (EQ a a)
T)
(FRAID (EQ 3 3)
T)
(FRAID (EQ (TamRep 'Cons 1)
(TamRep 'Cons 1))
T)
(FRAID (EQ (TamRep 'Cons 1)
(TamRep 'Cons 2))
NIL)
(FRAID (EQ (TamRep 'Character 1)
(TamRep 'Character 1))
T)
(FRAID (EQ (TamRep 'Character 1)
(TamRep 'Character 2))
NIL)
(* * * * * * * * * * New Page Required Here * * * * * * * * * *)
(JumpNewPage)
(FRAID (EQL a b)
NIL)
(FRAID (EQL a a)
T)
(FRAID (EQL 3 3)
T)
(FRAID (EQL (TamRep 'Character 1)
(TamRep 'Character 1))
T)
(FRAID (EQL (TamRep 'Character 1)
(TamRep 'Character 2))
NIL)
(FRAID (EQL (TamRep 'Character (LOGOR 1024 1))
(TamRep 'Character (LOGOR 1280 1)))
T)
(FRAID (EQL (TamRep 'Character (LOGOR 1024 1))
(TamRep 'Character (LOGOR 1024 2)))
NIL)
(FRAID (EQL (TamRep 'Cons 1)
(TamRep 'Cons 1))
T)
(FRAID (EQL (TamRep 'Cons 1)
(TamRep 'Cons 2))
NIL)
(FRAID (EQL (TamRep 'Number 1)
(TamRep 'Number 2))
EQL-UFN)
(FRAID (EQL (TamRep 'Number 1)
(TamRep 'Number (LOGOR 134217728 1)))
NIL)
(FRAID (EQL (TamRep 'Number 1)
1)
NIL)
(* * * * * * * * * * New Page Required Here * * * * * * * * * *)
(JumpNewPage)
(FRAID (EQUAL a b)
NIL)
(FRAID (EQUAL a a)
T)
(FRAID (EQUAL 3 3)
T)
(FRAID (EQUAL (TamRep 'Character 1)
(TamRep 'Character 1))
T)
(FRAID (EQUAL (TamRep 'Character 1)
(TamRep 'Character 2))
NIL)
(FRAID (EQUAL (TamRep 'Character (LOGOR 1024 1))
(TamRep 'Character (LOGOR 1280 1)))
T)
(FRAID (EQUAL (TamRep 'Character (LOGOR 1024 1))
(TamRep 'Character (LOGOR 1024 2)))
NIL)
(FRAID (EQUAL (TamRep 'Cons 1)
(TamRep 'Cons 1))
T)
(FRAID (EQUAL (TamRep 'Cons 1)
(TamRep 'Cons 2))
EQUAL-UFN)
(FRAID (EQUAL (TamRep 'Number 1)
(TamRep 'Number 2))
EQUAL-UFN)
(FRAID (EQUAL (TamRep 'Number 1)
(TamRep 'Number (LOGOR 134217728 1)))
NIL)
(FRAID (EQUAL (TamRep 'Imm 1)
(TamRep 'Imm 2))
NIL)
(FRAID (EQUAL (TamRep 'Code 1)
(TamRep 'Code 2))
EQUAL-UFN)))
(RPAQQ equfns [[AddFn '(EQL ((RETURN EQL-UFN]
[AddFn '(EQUAL ((RETURN EQUAL-UFN]
(AddFn '(GREATERP ((RETURN GREATERP-UFN])
(RPAQQ frameflagstest (@ 0 * frameflagscode STOP * frameflagufns STOP))
(RPAQQ frameflagscode ((CLRFLAGS.N 248)
(FRAID (TESTFLAGS.N 255)
NIL)
(SETFLAGS.N 16)
(FRAID (TESTFLAGS.N 255)
T)
(FRAID (TESTFLAGS.N 16)
T)
(FRAID (TESTFLAGS.N 8)
NIL)
(SETFLAGS.N 8)
(FRAID (TESTFLAGS.N 16)
T)
(FRAID (TESTFLAGS.N 64)
NIL)
(FRAID (TESTFLAGS.N 8)
T)
(SETFLAGS.N 128)
(FRAID (TESTFLAGS.N 128)
T)
(FRAID (TESTFLAGS.N 16)
T)
(CLRFLAGS.N 16)
(FRAID (TESTFLAGS.N 16)
NIL)
(FRAID (TESTFLAGS.N 128)
T)
(FRAID (TESTFLAGS.N 8)
T)
(FRAID (TESTFLAGS.N 64)
NIL)
(* * Call a function & change its flags)
(FRAID (FN1 FrameFlagFn 1)
FrameFlagsOk)
(FRAID (TESTFLAGS.N 128)
T)
(FRAID (TESTFLAGS.N 64)
NIL)
(FRAID (TESTFLAGS.N 8)
T)))
(RPAQQ frameflagufns [(AddFn '(FrameFlagFn ((CLRFLAGS.N 248)
(* * Should Have bit 0 on from number of Args)
(FRAID (TESTFLAGS.N 1)
T)
(FRAID (TESTFLAGS.N 2)
NIL)
(FRAID (TESTFLAGS.N 4)
NIL)
(* * Return the Symbol)
(RETURN FrameFlagsOk])
(RPAQQ vartest (@ 0 * varcode STOP * varufns STOP))
(RPAQQ varcode ((WRITEOCTNIL.N 0)
(WRITEOCTUNBOUND.N 8)
(SCONST Marker)
(FRAID (VAR0)
NIL)
(FRAID (VAR1)
NIL)
(FRAID (VAR2)
NIL)
(FRAID (VAR3)
NIL)
(FRAID (VAR4)
NIL)
(FRAID (VAR5)
NIL)
(FRAID (VAR6)
NIL)
(FRAID (VAR7)
NIL)
(FRAID (VAR8)
Unbound)
(FRAID (VAR9)
Unbound)
(FRAID (VAR10)
Unbound)
(FRAID (VAR11)
Unbound)
(FRAID (VAR12)
Unbound)
(FRAID (VAR13)
Unbound)
(FRAID (VAR14)
Unbound)
(FRAID (VAR15)
Unbound)
(VAR0←↑ 1)
(VAR1←↑ 2)
(VAR2←↑ 3)
(VAR3←↑ 4)
(VAR4←↑ 5)
(VAR5←↑ 6)
(VAR6←↑ 7)
(VAR7←↑ 8)
(VAR8←↑ 9)
(VAR9←↑ 10)
(VAR10←↑ 11)
(VAR11←↑ 12)
(VAR12←↑ 13)
(VAR13←↑ 14)
(VAR14←↑ 15)
(VAR15←↑ 16)
(FRAID (NOP)
Marker)
(SCONST Marker2)
(FRAID (VARX 0)
16)
(FRAID (VARX 1)
15)
(FRAID (VARX 2)
14)
(FRAID (VARX 3)
13)
(FRAID (VARX 4)
12)
(FRAID (VARX 5)
11)
(FRAID (VARX 6)
10)
(FRAID (VARX 7)
9)
(FRAID (VARX 8)
8)
(FRAID (VARX 9)
7)
(FRAID (VARX 10)
6)
(FRAID (VARX 11)
5)
(FRAID (VARX 12)
4)
(FRAID (VARX 13)
3)
(FRAID (VARX 14)
2)
(FRAID (VARX 15)
1)
(VARX←↑ 0 1)
(VARX←↑ 1 2)
(VARX←↑ 2 3)
(VARX←↑ 3 4)
(VARX←↑ 4 5)
(VARX←↑ 5 6)
(VARX←↑ 6 7)
(VARX←↑ 7 8)
(VARX←↑ 8 9)
(VARX←↑ 9 10)
(VARX←↑ 10 11)
(VARX←↑ 11 12)
(VARX←↑ 12 13)
(VARX←↑ 13 14)
(VARX←↑ 14 15)
(VARX←↑ 15 16)
(FRAID (NOP)
Marker2)
(FRAID (VARX 0)
16)
(FRAID (VARX 1)
15)
(FRAID (VARX 2)
14)
(FRAID (VARX 3)
13)
(FRAID (VARX 4)
12)
(FRAID (VARX 5)
11)
(FRAID (VARX 6)
10)
(FRAID (VARX 7)
9)
(FRAID (VARX 8)
8)
(FRAID (VARX 9)
7)
(FRAID (VARX 10)
6)
(FRAID (VARX 11)
5)
(FRAID (VARX 12)
4)
(FRAID (VARX 13)
3)
(FRAID (VARX 14)
2)
(FRAID (VARX 15)
1)))
(RPAQQ varufns (STOP))
(RPAQQ tostest (@ 0 * toscode STOP * tosufns))
(RPAQQ toscode ((SETTOS 18)
(SCONST Marker)
(FRAID (SWAP 0 1)
0)
(FRAID (COPY)
1)
(FRAID (POP)
Marker)
(SCONST Marker2)
%'0 %'0 %'0 %'1 (FRAID (MOVETOS 20)
1)
(FRAID (NOP)
Marker2)
(SETTOS 16)))
(RPAQQ tosufns (STOP))
(RPAQQ listtest (@ 0 (InitClink 8)
(UfnBase)
* listcode STOP * listufns))
(RPAQQ listcode [(* * Ref Counted Lists)
(VAR0←↑ '(a b c))
(FRAID (CAR (VAR0))
a)
(FRAID (CDR '(a b c))
'(b c))
(POP (SETF-CAR (VAR0)
d))
(FRAID (CAR (VAR0))
d)
(FRAID (CDR (VAR0))
'(b c))
[POP (SETF-CDR (VAR0)
'(m o]
(FRAID (CDR (VAR0))
'(m o))
(FRAID (CAR (VAR0))
d)
[POP (SETF-CAR (VAR0)
'(d f]
(FRAID (CAR (VAR0))
'(d f))
(FRAID (CDR (VAR0))
'(m o))
(* * Non Ref Counted Lists)
(VAR0←↑ '(1 2 3))
(FRAID (CAR (VAR0))
1)
(FRAID (CDR '(1 2 3))
'(2 3))
(POP (SETF-CAR (VAR0)
4))
(FRAID (CAR (VAR0))
4)
(FRAID (CDR (VAR0))
'(2 3))
[POP (SETF-CDR (VAR0)
'(6 7]
(FRAID (CDR (VAR0))
'(6 7))
(FRAID (CAR (VAR0))
4)
[POP (SETF-CAR (VAR0)
'(8 9]
(FRAID (CAR (VAR0))
'(8 9))
(FRAID (CDR (VAR0))
'(6 7])
(RPAQQ listufns (STOP))
(RPAQQ ptrtest (@ 0 (InitClink 8)
(UfnBase)
* ptrcode STOP * ptrufns))
(RPAQQ ptrcode ((FRAID (PUTTAG.N 0 PtrVar 4)
PtrVar)
(FRAID (PUTTAG.N 0 PtrVar2 4)
PtrVar2)
(FRAID (PUTBASEPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar PtrVar)
PtrVar)
(FRAID (PUTBASEPTR.N (UProp 'DefCellOffset 'k2)
PtrVar
(TamRep 'Code 2))
PtrVar)
(FRAID (GETBASEPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar)
PtrVar)
(FRAID (GETBASE.N (UProp 'ValueCellOffset 'k2)
PtrVar)
(AtomIndex 'PtrVar))
(FRAID (SYMBOLCELL.N (UProp 'DefCellOffset 'k2)
PtrVar)
(TamRep 'Code 2))
(FRAID (GETBASE.N (UProp 'DefCellOffset 'k2)
PtrVar)
2)
(FRAID (PUTBASEPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar 1)
PtrVar)
(FRAID (RPLPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar PtrVar2)
PtrVar)
(FRAID (GETBASEPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar)
PtrVar2)
(FRAID (PUTBASEPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar
(TamRep 'Stack 4))
PtrVar)
(FRAID (GETBASE.N (UProp 'ValueCellOffset 'k2)
PtrVar)
4)
(FRAID (GETBASEPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar)
(TamRep 'Stack 4))
(FRAID (ADDBASE (TamRep 'Code 2)
1)
(TamRep 'Ptr1 3))
(* * Test the Error Checking * *)
(UfnEntry '(GETBASEPTR.N GETBASE.N SYMBOLCELL.N PUTBASEPTR.N RPLPTR.N ADDBASE))
(FRAID (GETBASEPTR.N (UProp 'ValueCellOffset 'k2)
Unbound)
GETBASEPTR.N-UFN)
(FRAID (GETBASE.N (UProp 'DefCellOffset 'k2)
Unbound)
GETBASE.N-UFN)
(FRAID (SYMBOLCELL.N (UProp 'DefCellOffset 'k2)
(TamRep 'Code 2))
SYMBOLCELL.N-UFN)
(FRAID (PUTBASEPTR.N (UProp 'ValueCellOffset 'k2)
1 1)
PUTBASEPTR.N-UFN)
(FRAID (RPLPTR.N (UProp 'ValueCellOffset 'k2)
Unbound 1)
RPLPTR.N-UFN)
(FRAID (ADDBASE PtrVar Unbound)
ADDBASE-UFN)
(FRAID (ADDBASE Unbound 15)
ADDBASE-UFN)
(* * Let RplPtr attempt Reference Counting * *)
(FRAID (PUTTAG.N 0 PtrDecRef 4)
PtrDecRef)
(FRAID (PUTTAG.N 0 PtrVar2 4)
PtrVar2)
(FRAID (PUTTAG.N 0 PtrIncRef 4)
PtrIncRef)
(FRAID (PUTBASEPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar PtrDecRef)
PtrVar)
(FRAID (RPLPTR.N (UProp 'ValueCellOffset 'k2)
PtrVar PtrIncRef)
PtrVar)))
(RPAQQ ptrufns [[AddFn '(GETBASEPTR.N ((RETURN GETBASEPTR.N-UFN]
[AddFn '(GETBASE.N ((RETURN GETBASE.N-UFN]
[AddFn '(SYMBOLCELL.N ((RETURN SYMBOLCELL.N-UFN]
[AddFn '(PUTBASEPTR.N ((RETURN PUTBASEPTR.N-UFN]
[AddFn '(RPLPTR.N ((RETURN RPLPTR.N-UFN]
(AddFn '(ADDBASE ((RETURN ADDBASE-UFN])
(RPAQQ cstoretest (@ 0 (InitClink 8)
(UfnBase)
* cstorecode STOP * cstoreufns))
(RPAQQ cstorecode ((UfnEntry '(CSTORE CSTORETAG))
(* * Initial Setup of the Conditional Pointer & Slot Value * *)
(ADDBASE CStoreVar 1)
VAR0←↑
(PUTBASEPTR.N 0 VAR0 0)
(PUTTAG.N 0 7)
POP
(* * Test the Opcode * *)
(FRAID (CSTORE (VAR0)
0 1)
T)
(FRAID (CSTORE (VAR0)
1 2)
T)
(FRAID (CSTORE (VAR0)
3 4)
NIL)
(FRAID (CSTORE (VAR0)
3 2)
NIL)
(FRAID (CSTORE Unbound 3 2)
CSTORE-UFN)
(* * Test the Conditional Store Tag Opcode * *)
(FRAID (CSTORETAG (VAR0)
7 1)
T)
(FRAID (CSTORETAG (VAR0)
1 5)
T)
(FRAID (CSTORETAG (VAR0)
3 4)
NIL)
(FRAID (CSTORETAG (VAR0)
3 2)
NIL)
(FRAID (CSTORETAG Unbound 3 2)
CSTORETAG-UFN)
(* * Make Sure That The Operations Didn't Zap the Data * *)
(FRAID (GETBASEPTR.N 0 VAR0)
2)
(FRAID (GETTAG.N 0 VAR0)
5)))
(RPAQQ cstoreufns [[AddFn '(CSTORE ((RETURN CSTORE-UFN]
(AddFn '(CSTORETAG ((RETURN CSTORETAG-UFN])
(* ;; " Not yet in fulltest")
(RPAQQ closuretest (@ 0 (InitClink 8)
(UfnBase)
* closurecode STOP * closureufns))
(RPAQQ closurecode ((FRAID (FN1 ClosureFn 1)
1)
(FRAID (FN1 ClosureFn 1)
2)
(FRAID (FN1 ClosureFn 4)
6)
(FRAID (FN1 ClosureFn 0)
6)))
(RPAQQ closureufns [[AddFn '(ClosureFn ((VARX (UProp 'ClosureEnvSlot 'k))
(GETBASEPTR.N 2)
VAR0 PLUS COPY (VARX (UProp 'ClosureEnvSlot 'k))
SWAP
(PUTBASEPTR.N 2)
POP RETURN]
(MakeClosure '(ClosureFn (0 1])
(RPAQQ undefntest (@ 0 (InitClink 8)
(UfnBase)
* undefncode STOP * undefnufns))
(RPAQQ undefncode ((SYMBOLCELL.N (UProp 'DefCellOffset 'k2)
Undefined-Ufn)
(IREGX←↑ (UProp 'UnDefFn 'k))
(FRAID (FN1 No-Fn)
No-Fn)
(FRAID (VAR0)
1)
(FRAID (FN0 No-Fn2)
No-Fn2)
(FRAID (VAR0)
0)
(FRAID (FN7 No-Fn7 0 1 2 3 4 5 6)
No-Fn7)
(FRAID (VAR0)
7)))
(RPAQQ undefnufns [(AddFn '(Undefined-Ufn ([OVAR1.X←↑ 0 (LOGAND (SICX 7)
(VARX (UProp 'HdrSlot 'k]
(VARX (UProp 'UnDefnSlot 'k))
RETURN])
(RPAQQ gctest (@ 0 (InitClink 8)
(UfnBase)
* gccode STOP * gcufns))
(RPAQQ gccode ((IREGX←↑ (UProp 'RefCountCode 'k)
(SYMBOLCELL.N (UProp 'DefCellOffset 'k2)
RefCountUfn))
(POP)
(* * Setup the Reference Counts and Global Value slot * *)
(PUTTAG.N 0 RCObj1 5)
(PUTTAG.N 0 RCObj2 6)
(PUTBASEPTR.N (UProp 'ValueCellOffset 'k2)
RCGvar 0)
(FRAID (GETTAG.N 0 RCObj1)
5)
(FRAID (GETTAG.N 0 RCObj2)
6)
(* * Cycle GVAR← through RCObj1 RCObj2 & 0)
(GVAR←↑ RCGvar RCObj1)
(FRAID (GETTAG.N 0 RCObj1)
6)
(GVAR←↑ RCGvar RCObj2)
(FRAID (GETTAG.N 0 RCObj1)
5)
(FRAID (GETTAG.N 0 RCObj2)
7)
(GVAR←↑ RCGvar 0)
(FRAID (GETTAG.N 0 RCObj2)
6)
(* * Overflow Test Using INCREFCOUNT VAR0 hack determines if Ufn called * *)
(PUTTAG.N 0 RCObj1 15)
(INCREFCOUNT RCObj1)
(FRAID (VAR0)
15)
(FRAID (GETTAG.N 0 RCObj1)
8)
(* * Underflow Tests Using DECREFCOUNT * *)
(DECREFCOUNT RCObj1)
(FRAID (GETTAG.N 0 RCObj1)
7)
(PUTTAG.N 0 RCObj1 1)
(DECREFCOUNT RCObj1)
(FRAID (VAR0)
1)
(FRAID (GETTAG.N 0 RCObj1)
0)
(DECREFCOUNT RCObj1)
(FRAID (VAR0)
0)
(FRAID (GETTAG.N 0 RCObj1)
8)))
(RPAQQ gcufns [(AddFn '(RefCountUfn ((IFExpr (EQ 0 (VAR1))
(NOP)
((VAR1)
(OVAR1.X←↑ 0 (GETTAG.N 0 (VAR1))
(COPY))
(ADDX 1)
(COPY)
(IFExpr (GREATERP 15)
((POP)
(SICX 8)))
(PUTTAG.N 0)))
(IFExpr (EQ 0 (VAR0))
(NOP)
((VAR1←↑ (GETTAG.N 0 (VAR0)))
(VAR0)
(OVAR1.X←↑ 0 VAR1)
(VAR1)
(IFExpr (GREATERP VAR1 0)
((SUBX 1))
((POP)
(SICX 8)))
(PUTTAG.N 0)))
RETNP])
(RPAQQ constest (@ 0 (InitClink 8)
(UfnBase)
* conscode STOP * consufns * gcufns))
(RPAQQ conscode ((UfnEntry '(CONS RPLCONS))
(IREGX←↑ (UProp 'RefCountCode 'k)
(SYMBOLCELL.N (UProp 'DefCellOffset 'k2)
RefCountUfn))
(* * RplCons Checks * *)
(VAR2←↑ '(1 8))
(VAR1←↑ (RPLCONS VAR2 2))
(FRAID (CAR VAR1)
2)
(FRAID (CDR VAR1)
NIL)
(FRAID (CAR VAR2)
1)
(FRAID (CDR VAR2)
VAR1)
(VAR2←↑ (CONS RplVar1 RplVar2))
(PUTTAG.N 0 RplVar1 2)
(PUTTAG.N 0 RplVar2 3)
(PUTTAG.N 0 RplVar3 4)
(RPLCONS VAR2 RplVar3)
(FRAID 5 (GETTAG.N 0 RplVar3))
(FRAID 2 (GETTAG.N 0 RplVar2))
(FRAID 2 (GETTAG.N 0 RplVar1))
(* * Cons Checks * *)
(VAR0←↑ (CONS 1 2))
(FRAID (CDR VAR0)
2)
(FRAID (CAR VAR0)
1)
(* * Make Sure the Reference Counts of Objects is Bumped * *)
(GETTAG.N 0 CarVar)
(GETTAG.N 0 CdrVar)
(VAR1←↑ (CONS CarVar CdrVar))
(FRAID (ADDX 1)
(GETTAG.N 0 CdrVar))
(FRAID (ADDX 1)
(GETTAG.N 0 CarVar))
(* * Tryout a RefCount Overflow * *)
(PUTTAG.N 0 CarVar 15)
(GETTAG.N 0 CdrVar)
(VAR1←↑ (CONS CarVar CdrVar))
(FRAID (ADDX 1)
(GETTAG.N 0 CdrVar))
(FRAID 8 (GETTAG.N 0 CarVar))
(* * Tryout a Cons When the Ptr is Nil * *)
(IREGX←↑ (UProp 'ConsPtr 'k)
NIL)
(FRAID (CONS 3 4)
CONS-UFN)))
(RPAQQ consufns [[AddFn '(CONS ((RETURN CONS-UFN]
(AddFn '(RPLCONS ((RETURN RPLCONS-UFN])
(RPAQQ slowrettest (@ 0 (InitClink 8)
(UfnBase)
* slowretcode STOP * slowretufns))
(RPAQQ slowretcode ((UfnEntry '(RETURN RETNP))
(FRAID (FN1 RetChkFn 0)
9)
(FRAID (FN1 RetChkFn 1)
Slow-Ret)
(FRAID (FN7 RetChkFn 0 1 2 3 4 5 6)
Fn7-Ret)
(FRAID (FN2 RetChkFn 0 1)
Fn2-Ret)
(FRAID 1 (FN1 RetChkFn 2)
1)))
(RPAQQ slowretufns [[AddFn '(RetChkFn ((IFExpr [EQ 7 (LOGAND 7 (VARX (UProp 'HdrSlot 'k]
((RETURN Fn7-Ret)))
(IFExpr [EQ 2 (LOGAND 7 (VARX (UProp 'HdrSlot 'k]
((RETURN Fn2-Ret)))
(IFExpr (EQ VAR0 0)
((RETURN 9)))
(IFExpr (EQ VAR0 1)
((SETFLAGS.N (UProp 'SlowReturnMask 'k))
(RETURN NIL)))
(RETNP RetChkFn]
[AddFn '(RETURN ((OVAR1.X←↑ (UProp 'HdrSlot 'k)
(LOGAND (OVAR1.X (UProp 'HdrSlot 'k))
4294967040))
(RETURN Slow-Ret]
(AddFn '(RETNP ((OVAR1.X←↑ (UProp 'HdrSlot 'k)
(LOGAND (OVAR1.X (UProp 'HdrSlot 'k))
4294967040))
(RETNP])
(RPAQQ jumptest (@ 0 * jumpcode STOP))
(RPAQQ jumpcode ((FRAID JumpMarker (JUMPK RAID RAID)
JumpMarker)
(FRAID JumpMarker (%'T)
(TJUMPK↑ RAID RAID RAID)
JumpMarker)
(FRAID JumpMarker (%'NIL)
(FJUMPK↑ RAID RAID RAID RAID)
JumpMarker)
(FRAID (%'T)
(FJUMPK↑ JumpMarker)
JumpMarker)
(FRAID (%'NIL)
(TJUMPK↑ JumpMarker)
JumpMarker)
(FRAID JumpMarker (JUMPX RAID RAID RAID RAID)
JumpMarker)
(FRAID JumpMarker (%'T)
(TJUMPX↑ RAID RAID RAID RAID RAID RAID RAID)
JumpMarker)
(FRAID JumpMarker (%'NIL)
(FJUMPX↑ RAID RAID RAID RAID RAID RAID)
JumpMarker)
(FRAID (%'T)
(FJUMPX↑ JumpMarker)
JumpMarker)
(FRAID (%'NIL)
(TJUMPX↑ JumpMarker)
JumpMarker)
(FRAID (%'T)
(N↑TJUMPX RAID RAID RAID RAID RAID RAID RAID)
%'T)
(FRAID (%'NIL)
(N↑FJUMPX RAID RAID RAID RAID RAID RAID RAID)
%'NIL)
(FRAID JumpMarker (%'NIL)
(N↑TJUMPX RAID RAID RAID)
JumpMarker)
(FRAID JumpMarker (%'T)
(N↑FJUMPX RAID RAID RAID)
JumpMarker)
(FRAID JumpMarker (JUMPXX RAID RAID RAID RAID)
JumpMarker)))
(RPAQQ applytest (@ 0 (InitClink 8)
(UfnBase)
* applycode STOP * applyufn))
(RPAQQ applycode ((UfnEntry '(APPLY MV-APPLY TAIL-APPLY))
(FRAID (APPLY 3 4 ApplyTailFnPlus 2)
7)
(FRAID 4 (APPLY 3 4 ApplyTailFnConser 2))
(FRAID (APPLY 3 4 ApplyFn1 2)
7)
(FRAID (APPLY 3 4 5 2)
APPLY-UFN)
(FRAID (APPLY 3 4 ApplyFn1 8)
APPLY-UFN)
(FRAID 4 (APPLY 3 4 ApplyConser 2))
(FRAID (IREGX (UProp 'ConsPtr 'k))
(MV-APPLY 3 4 ApplyConser 2))
(FRAID (IREGX (UProp 'ConsPtr 'k))
(MV-APPLY 3 4 ApplyTailFnConser 2))
(FRAID (APPLY 4 4 ApplyFnPlus 2)
8)))
(RPAQQ applyufn [[AddFn '(ApplyFn1 ((RETURN (PLUS VAR0 VAR1]
[AddFn '(APPLY ((RETURN APPLY-UFN]
[AddFn '(MV-APPLY ((RETURN MV-APPLY-UFN]
[AddFn '(TAIL-APPLY ((RETURN TAIL-APPLY-UFN]
[AddFn '(ApplyConser ((IFExpr (TESTFLAGS.XX (UProp 'MultipleValueMask 'k))
((RETURN (CONS VAR0 VAR1)))
((RETURN VAR1]
[AddFn '(ApplyTailFnConser ((RETURN (TAIL-APPLY VAR0 VAR1 ApplyConser 2]
[AddFn '(ApplyTailFnPlus ((RETURN (TAIL-APPLY VAR0 VAR1 ApplyFnPlus 2]
(AddFn '(ApplyFnPlus ((RETURN (PLUS VAR0 VAR1])
(RPAQQ fntest (@ 0 (InitClink 2)
(UfnBase)
* fncode STOP * fnufn))
(RPAQQ fncode ((FRAID (IREGX (UProp 'ConsPtr 'k))
(MV-FN2 TailFnConser 2 4))
(FRAID (FN2 TailFnPlus 5 2)
7)
(FRAID (FN2 FnPlus 2 4)
6)
(FRAID (IREGX (UProp 'ConsPtr 'k))
(MV-FN2 Conser 2 4))
(FRAID 4 (FN2 Conser 2 4))
(FRAID 4 (FN2 TailFnConser 2 4))))
(RPAQQ fnufn [[AddFn '(FN0 ((RETURN FN0-UFN]
[AddFn '(FN1 ((RETURN FN1-UFN]
[AddFn '(FN2 ((RETURN FN2-UFN]
[AddFn '(FN3 ((RETURN FN3-UFN]
[AddFn '(FN4 ((RETURN FN4-UFN]
[AddFn '(FN5 ((RETURN FN5-UFN]
[AddFn '(FN6 ((RETURN FN6-UFN]
[AddFn '(FN7 ((RETURN FN7-UFN]
[AddFn '(Fn1 ((NOP 0 1 2 3)
(RETURN 1]
[AddFn '(Fn2 ((NOP 0 1 2 3 4 5)
(RETURN 2]
[AddFn '(FnPlus ((RETURN (PLUS VAR0 VAR1]
[AddFn '(TailFnPlus ((RETURN (TAIL-FN2 FnPlus VAR0 VAR1]
[AddFn '(Conser ((IFExpr (TESTFLAGS.XX (UProp 'MultipleValueMask 'k))
((RETURN (CONS VAR0 VAR1)))
((RETURN VAR1]
(AddFn '(TailFnConser ((RETURN (TAIL-FN2 Conser VAR0 VAR1])
(* * Un Modified for CMOS)
(RPAQQ simtest
(@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← COPY GETBASEPTR.N [CADR (FASSOC 'nextlink (GETPROP 'k 'uField]
SICX
(LOGOR (TamTagRep 'Frame)
1)
SETSUBTYPE PUTBASEPTR.N [CADR (FASSOC 'nextlink (GETPROP 'k 'uField]
PCONST
(EvalBytes 4 (TamRep 'Code 256))
IREGX←
(LOGAND [CADR (FASSOC 'frameflagcode (GETPROP 'k 'uField]
63)
PCONST
(EvalBytes 4 (TamRep 'Code 232))
IREGX←
[CADR (FASSOC 'intcode (GETPROP 'k 'uField]
PCONST
(EvalBytes 4 (TamRep 'Code 128))
IREGX←
[CADR (FASSOC 'pfcode (GETPROP 'k 'uField]
PCONST
(EvalBytes 4 (TamRep 'Code 320))
IREGX←
[CADR (FASSOC 'refcountcode (GETPROP 'k 'uField]
ACONST
(EvalBytes 3 (AddAtom 'UfnTable))
IREGX←
(LOGAND [CADR (FASSOC 'ufnbase (GETPROP 'k 'uField]
63)
PCONST
(EvalBytes 4 (TamRep 'Code 192))
PUTBASEPTR.N LLSH.N ENBINT %'NIL VAR8← POP %'T VAR9← VAR8 SWAP SICX 2 COPY %'1 PLUS
INTEGERP TJUMPX 1 STOP COPY %'1 PLUS JUMP15 STOP STOP STOP STOP STOP STOP STOP STOP STOP
STOP STOP STOP STOP STOP STOP NEG ICONST (EvalBytes 4 (TamRep 'Int 268435461))
SICX 3 DIFFERENCE POP SICX 3 NEG ASH SETTYPE.N (TamTagRep 'Float)
SICX
(TamTagRep 'Int)
SETSUBTYPE SICX 3 FLAGTYPEP.N 3 POP SUBTYPEP.N (LOGOR (TamTagRep 'Atm)
1)
GETTYPEBITS %'NIL GETPTRBITS GVAR [EvalBytes 3 (AddAtom 'B
(AddList '(11 (12 13)
14]
GVAR
[EvalBytes 3 (AddAtom 'A (AddList '(1 (11 (12 13)
14)
3 4 5 6]
CAR GVAR (EvalBytes 3 (AddAtom 'A))
CDR CDR GVAR (EvalBytes 3 (AddAtom 'A))
SICX 2 %'1 ACONST (EvalBytes 3 (AddAtom 'fn))
APPLYFN STOP (EvalBytes 0 (AddFnHeader 'fn 64))
%'0 %'1 MOVETOS 17 SETTOS 16 %'1 OVAR1.X← 8 VAR8 %'0 EQ TJUMPX 9 VAR8 SICX 1 DIFFERENCE FN1
(EvalBytes 3 (AddAtom 'fn))
RETURN OVAR1.X 8 GVAR (EvalBytes 3 (TamRep 'Ptr 2097216))
SETTOS 20 ICONST (EvalBytes 4 (TamRep 'Int 536870912))
LLSH.N 1 RETURN (EvalBytes 0 (AddFnHeader 'PfFn 128))
VAR8 ICONST (EvalBytes 4 (TamRep 16777215))
LOGAND LRSH.N 10 SETTYPE.N (TamRep 'Ptr)
COPY GETBASEPTR.N 0 VAR9← ICONST (EvalBytes 4 (TamRep 3))
LOGOR PUTBASEPTR.N 0 RESET-VMM RETNP (EvalBytes 0 (AddFnHeader 'llsh 192))
NOP %'1 RETNP (EvalBytes 0 (AddFnHeader 'irqfn 232))
%'1 RETEI (EvalBytes 0 (AddFnHeader 'FrameFn 256))
MYCLINK RETNP (EvalBytes 0 (AddFnHeader 'RcFn 320))
RETNP @ 2048 (EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 24))
(EvalBytes -4 (TamRep 28))
@ 4161 (EvalBytes -4 (TamRep 'Int 5))
(EvalBytes 0 (AddFnHeader 'Ovfn 2103296))
JUMPXX
(EvalBytes 2 4042)
@ 4201464 NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP
NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP %'0 %'1 %'NIL %'T NOP NOP NOP RETURN))
(RPAQQ simtracetest
(@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← PCONST (EvalBytes 4 (TamRep 'Code 64))
IREGX←
(LOGAND [CADR (FASSOC 'intcode (GETPROP 'k 'uField]
63)
ENBINT %'NIL SETOUTPUTINT DISINT WRITEOCTNIL.N 16 SETMEMLOCK WRITEOCTUNBOUND.N 16
CLRMEMLOCK WRITEOCTNIL.N 16 ENBINT CLROUTPUTINT WRITEOCTUNBOUND.N 16 NJUMPX 16
(EvalBytes 0 (AddFnHeader 'IrqFn 64))
%'0 RETEI))
(RPAQQ testgregops
(@ 0 %'1 IREGX← 0 %'1 PLUS IREGX← 1 %'0 IREGX← 39 IREGX 0 IREGX 1 IREGX 39 STOP))
(RPAQQ testcarcdrops (@ 0 GVAR [EvalBytes 3 (AddAtom 'B (AddList '(11 (12 13)
14]
GVAR
[EvalBytes 3 (AddAtom 'A (AddList '(1 (11 (12 13)
14)
3 4 5 6]
CAR GVAR (EvalBytes 3 (AddAtom 'A))
CDR CDR CDR CAR GVAR (EvalBytes 3 (AddAtom 'A))
CDR CAR CDR CAR STOP))
(RPAQQ testconstops2
(@ 0 NOP DUNBIND 13 ACONST 1 3 7 ICONST 1 3 7 0 FCONST 63 1 3 7 XCONST 63 1 3 7 PCONST 27 0 0
0 STOP))
(RPAQQ testshiftops (@ 0 %'1 %'1 ASH ICONST (EvalBytes 4 (TamRep -1))
ASH SICX 30 NEG ASH (EvalBytes 4 (TamRep -30))
ASH))
(RPAQQ teststackops (@ 0 %'0 %'1 SWAP COPY %'1 SWAP UNBIND 30 %'1 STOP))
(RPAQQ testconstops
(@ 0 %'T %'NIL %'0 %'1 %'UNBOUND SICX 255 SICXX 1 2 ICONST 1 3 7 0 ACONST
(EvalBytes 3 (AddAtom 'A))
FCONST 63 1 3 7 XCONST 63 1 3 7 PCONST (EvalBytes 4 (AddAtom 'A))
PCONST
[EvalBytes 4 (AddList '(A B C 1 2 3]
STOP))
(RPAQQ testops
(@ 0 %'0 %'1 %'NIL %'T %'1 %'1 %'1 %'1 %'1 %'1 %'1 %'1 %'1 %'1 SICX 5 SICX 4 GREATERP %'1 SICX
2 NEG GREATERP %'1 NEG SICX 2 NEG GREATERP %'1 NEG %'1 GREATERP STOP))
(RPAQQ testops2
(@ 0 NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP
NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP
NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP STOP))
(RPAQQ testovarops (@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← SICX 5 VARX← 6 VARX← 7 %'0 FN1 (EvalBytes 3 (AddAtom 'fn))
STOP STOP (EvalBytes 0 (AddFnHeader 'fn))
VAR8 OVAR1.X← 6 OVAR1.X 7 RETURN))
(RPAQQ testash (@ 0 %'1 %'1 ASH %'1 NEG ASH %'0 ASH ICONST (EvalBytes 4 (TamRep 'Int 1073741823))
SICX 2 NEG ASH SICX 2 ASH STOP))
(* * Variable referencing)
(RPAQQ testvarops
(@ 0 DUNBIND 13 VAR6←NIL VAR7←UNBOUND %'0 %'1 VAR6← POP VAR7←↑ VARX 6 VAR6 VARX 7 VAR7 VARX← 6
POP VARX← 7 POP VARX 6 VARX 7 STOP))
(RPAQQ testgvarops (@ 0 ACONST (EvalBytes 3 (AddAtom 'A (TamRep 'Int 5)))
%'1 GVAR (EvalBytes 3 (AddAtom 'A))
PCONST
(EvalBytes 4 (AddAtom 'A))
%'1 PUTBASEPTR.N 1 GVAR (EvalBytes 3 (AddAtom 'A))
STOP))
(RPAQQ fvartest
(@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← SICX 5 VARX← 6 SICX 6 VARX← 7 %'0 FN0 (EvalBytes 3 (AddAtom 'fn))
STOP STOP (EvalBytes 0 (AddFnHeader 'fn))
MYCLINK SICX 10 ADDBASE SICX (TamTagRep 'Ptr 1)
SETSUBTYPE VAR6← VAR13← SICX 2 ADDBASE VAR7← POP FVARX 6 %'1 PLUS FVARX← 6 VAR13 %'1
ADDBASE FVARX← 7 FVARM 2 %'1 PLUS FVARM← 2 VAR13 %'1 ADDBASE VAR6← ACONST
(EvalBytes 3 (AddAtom 'test (TamRep 'Int 1)))
%'1 ADDBASE FVARX← 6 FVARM 1 %'1 PLUS FVARM← 1 GVAR (EvalBytes 3 (AddAtom 'test))
RETURN))
(* * Jump Tests)
(RPAQQ testjumpops
(@ 0 %'T TJUMPX 0 %'T TJUMPX 2 %'0 %'1 %'NIL TJUMPX 2 %'0 %'1 %'NIL FJUMPX 2 %'0 %'1 %'T
FJUMPX 2 %'T NTJUMPX 2 %'0 %'1 %'T %'NIL NTJUMPX 2 NFJUMPX 2 %'NIL NFJUMPX 3 STOP STOP STOP
%'T STOP))
(RPAQQ smalljumps
(@ 0 NOP NOP1 STOP NOP2 STOP STOP NOP3 STOP STOP STOP NOP4 STOP STOP STOP STOP JUMP5 STOP STOP
STOP STOP STOP JUMP6 STOP STOP STOP STOP STOP STOP JUMP7 STOP STOP STOP STOP STOP STOP STOP
JUMP8 STOP STOP STOP STOP STOP STOP STOP STOP JUMP9 STOP STOP STOP STOP STOP STOP STOP STOP
STOP JUMP10 STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP JUMP11 STOP STOP STOP STOP
STOP STOP STOP STOP STOP STOP STOP JUMP12 STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP
STOP STOP JUMP13 STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP JUMP14
STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP JUMP15 STOP STOP STOP
STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP %'1 STOP))
(RPAQQ jumperror
(@ 0 JUMPX 103 STOP NOP2 STOP STOP NOP3 STOP STOP STOP NOP4 STOP STOP STOP STOP JUMP5 STOP
STOP STOP STOP STOP JUMP6 STOP STOP STOP STOP STOP STOP JUMP7 STOP STOP STOP STOP STOP STOP
STOP JUMP8 STOP STOP STOP STOP STOP STOP STOP STOP JUMP9 STOP STOP STOP STOP STOP STOP STOP
STOP STOP JUMP10 STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP JUMP11 STOP STOP STOP
STOP STOP STOP STOP STOP STOP STOP STOP JUMP12 STOP STOP STOP STOP STOP STOP STOP STOP STOP
STOP STOP STOP JUMP13 STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP
JUMP14 STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP JUMP15 STOP
STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP %'1 STOP))
(RPAQQ tfsmalljumps
(@ 0 %'NIL TJUMP2 %'T TJUMP2 STOP STOP %'T TJUMP0 %'NIL TJUMP0 %'T TJUMP15 STOP STOP STOP STOP
STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP STOP %'0 %'T FJUMP2 %'NIL FJUMP2 STOP
STOP %'NIL FJUMP0 %'T FJUMP0 %'NIL FJUMP15 STOP STOP STOP STOP STOP STOP STOP STOP STOP
STOP STOP STOP STOP STOP STOP %'1 STOP))
(RPAQQ negjumpx (@ 0 %'1 %'1 PLUS NJUMPX 4 STOP))
(RPAQQ negjumpxx (@ 0 %'1 %'1 PLUS NJUMPXX 5 0 STOP))
(RPAQQ ibuftest
(@ 0 %'0 VARX← 0 NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP PCONST
(EvalBytes 4 (AddAtom 'IrqFn))
GETBASEPTR.N 2 IREGX← (LOGAND [CADR (FASSOC 'intcode (GETPROP 'k 'uField]
63)
ENBINT SICX 0 %'1 PLUS ICONST (EvalBytes 4 (TamRep 175304714 0))
POP NJUMPX 10 STOP STOP (EvalBytes 0 (AddFnHeader 'IrqFn (NextFnAddr)))
%'1 RETEI))
(* * Function Call)
(RPAQQ fntest (@ 0 (InitClink 2)
(UfnBase)
* fncode STOP * fnufn))
(RPAQQ undefntest (@ 0 (InitClink 8)
(UfnBase)
* undefncode STOP * undefnufns))
(RPAQQ applytest (@ 0 (InitClink 8)
(UfnBase)
* applycode STOP * applyufn))
(RPAQQ fnops (@ 0 %'0 VARX← 0 FN1 [EvalBytes 3 (AddAtom 'Testfn NIL (AddCode 'Testfn]
STOP))
(RPAQQ ufn1dtest [@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← ACONST (EvalBytes 3 (AddAtom 'UfnTable))
IREGX←
(LOGAND [CADR (FASSOC 'ufnbase (GETPROP 'k 'uField]
63)
PCONST
(EvalBytes 4 (TamRep 'Code 64))
PUTBASEPTR.N LLSH.N %'T LLSH.N 1 %'1 STOP STOP (EvalBytes 0 (AddFnHeader
'ufn 64))
VAR8 VAR9 %'0 RETURN STOP (EvalBytes 0 (AddAtom 'UfnTable (TamRep 'Ptr
FreeMemIndex])
(RPAQQ ufn2test [@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← ACONST (EvalBytes 3 (AddAtom 'UfnTable))
IREGX←
(LOGAND [CADR (FASSOC 'ufnbase (GETPROP 'k 'uField]
63)
PCONST
(EvalBytes 4 (TamRep 'Code 64))
PUTBASEPTR.N PLUS %'T %'0 PLUS %'1 STOP STOP (EvalBytes 0 (AddFnHeader
'ufn 64))
VAR8 VAR9 %'0 RETURN STOP (EvalBytes 0 (AddAtom 'UfnTable (TamRep 'Ptr
FreeMemIndex])
(RPAQQ frameadjust (@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← COPY GETBASEPTR.N [CADR (FASSOC 'nextlink (GETPROP 'k 'uField]
SICX
(LOGOR (TamTagRep 'Frame)
1)
SETSUBTYPE PUTBASEPTR.N [CADR (FASSOC 'nextlink (GETPROP 'k 'uField]
PCONST
(EvalBytes 4 (TamRep 'Code 256))
IREGX←
(LOGAND [CADR (FASSOC 'frameflagcode (GETPROP 'k 'uField]
63)
SICX 0 FN1 (EvalBytes 3 (AddAtom 'fn NIL (TamRep 'Code 64)))
STOP STOP (EvalBytes 0 (AddFnHeader 'fn 64))
MYCLINK VAR8 %'0 EQ TJUMPX 9 VAR8 SICX 1 DIFFERENCE FN1
(EvalBytes 3 (AddAtom 'fn))
RETURN %'1 RETURN (EvalBytes 0 (AddFnHeader 'ffn 256))
NOP %'1 RETNP))
(RPAQQ ufndump (@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 8))
MYCLINK← ACONST (EvalBytes 3 (AddAtom 'UfnTable))
IREGX←
(LOGAND [CADR (FASSOC 'ufnbase (GETPROP 'k 'uField]
63)
PCONST
(EvalBytes 4 (TamRep 'Code 256))
PUTBASEPTR.N LLSH.N SICX 3 FN1 (EvalBytes 3 (AddAtom 'fn))
STOP STOP (EvalBytes 0 (AddFnHeader 'fn 64))
VAR8 %'0 EQ TJUMPX 9 VAR8 SICX 1 DIFFERENCE FN1 (EvalBytes 3 (AddAtom 'fn))
RETURN ICONST (EvalBytes 4 (TamRep 'Int 268435456))
LLSH.N 1 %'T RETURN (EvalBytes 0 (AddFnHeader 'ufn 256))
%'1 RETURN))
(* * Interrupt Tests)
(RPAQQ irqenbtest (@ 0 DISINT DISINT DISINT ENBINT ENBINT ENBINT ENBINT STOP))
(* * Virtual Memory Tests)
(RPAQQ vmtest (@ 0 PCONST (EvalBytes 4 (TamRep 'Code 64))
IREGX←
[CADR (FASSOC 'pfcode (GETPROP 'k 'uField]
PCONST
(EvalBytes 4 (TamRep 'Ptr 2097216))
COPY GETBASEPTR.N 0 %'1 PLUS PUTBASEPTR.N 0 PCONST (EvalBytes 4 (TamRep 'Ptr 2098240
))
GETBASEPTR.N 0 PCONST (EvalBytes 4 (TamRep 'Ptr 2097216))
GETBASEPTR.N 0 STOP (EvalBytes 0 (AddFnHeader 'PfFn 64))
VAR8 LRSH.N 9 VAR7← ICONST (EvalBytes 4 4096)
VAR8← %'0 VAR9← SICX 3 GREATERP TJUMPX 39 VAR8 VAR9 PLUS VAR10← SETTYPE.N
(TamTagRep 'Ptr)
COPY GETBASEPTR.N 0 SETTYPE.N (TamTagRep 'Int)
VAR7 VAR10 EQ TJUMPX 8 ICONST (EvalBytes 4 (TamRep 4096))
LOGOR JUMPX 6 ICONST (EvalBytes 4 (TamRep 511))
LOGAND SETTYPE.N (TamTagRep 'Ptr)
PUTBASEPTR.N 0 VAR9 %'1 PLUS NJUMPX 45 RESET-VMM RETNP @ 2048 (EvalBytes -4 16)
(EvalBytes -4 17)
(EvalBytes -4 30)
(EvalBytes -4 2)
@ 4160 (EvalBytes -4 (TamRep 'Int 5))))
(RPAQQ vmtest2 (@ 0 PCONST (EvalBytes 4 (TamRep 'Code 64))
IREGX←
[CADR (FASSOC 'pfcode (GETPROP 'k 'uField]
PCONST
(EvalBytes 4 (TamRep 'Ptr 4194369))
%'1 PUTBASEPTR.N 0 GVAR (EvalBytes 3 (TamRep 'Atm 4194368))
GVAR←
(EvalBytes 3 (TamRep 'Atm 4194368))
STOP
(EvalBytes 0 (AddFnHeader 'pfn 64))
VAR8 LRSH.N 10 SETTYPE.N (TamTagRep 'Ptr)
COPY GETBASEPTR.N 0 VAR9← %'1 LOGAND %'1 EQ TJUMPX 7 ICONST (EvalBytes 4
(TamRep
1073741820
))
JUMPX 5 ICONST (EvalBytes 4 (TamRep 1073741822))
VAR9 LOGAND PUTBASEPTR.N 0 RESET-VMM RETNP @ 4096 (EvalBytes -4 (TamRep 19))
(EvalBytes -4 19)
(EvalBytes -4 23)
(EvalBytes -4 23)
@ 4161 (EvalBytes -4 (TamRep 'Int 5))))
(RPAQQ vmtest3
(@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (TamRep 'Code 128))
IREGX←
[CADR (FASSOC 'pfcode (GETPROP 'k 'uField]
PCONST
(EvalBytes 4 (TamRep 'Code 64))
IREGX←
[CADR (FASSOC 'refcountcode (GETPROP 'k 'uField]
GVAR
(EvalBytes 3 (TamRep 'Ptr 2097216))
%'1 PLUS GVAR← (EvalBytes 3 (TamRep 'Ptr 2097216))
PCONST
(EvalBytes 4 (TamRep 'Ptr 2098177))
COPY GETBASEPTR.N 64 %'1 PLUS PUTBASEPTR.N 64 PCONST (EvalBytes 4 (TamRep 'Ptr 2099201))
COPY GETBASEPTR.N 64 %'1 PLUS RPLPTR.N 64 FN0 (EvalBytes 3 (AddAtom 'Ovfn))
STOP
(EvalBytes 0 (AddFnHeader 'RcFn 64))
RETNP
(EvalBytes 0 (AddFnHeader 'PfFn 128))
VAR8 ICONST (EvalBytes 4 (TamRep 16777215))
LOGAND LRSH.N 10 SETTYPE.N (TamRep 'Ptr)
COPY GETBASEPTR.N 0 VAR9← %'1 LOGAND %'1 EQ FJUMPX 7 ICONST (EvalBytes 4 (TamRep 3))
JUMPX 5 ICONST (EvalBytes 4 (TamRep 1))
VAR9 LOGOR PUTBASEPTR.N 0 RESET-VMM RETNP @ 2048 (EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 16))
(EvalBytes -4 (TamRep 24))
(EvalBytes -4 (TamRep 28))
@ 4161 (EvalBytes -4 (TamRep 'Int 5))
(EvalBytes 0 (AddFnHeader 'Ovfn 2103296))
JUMPXX
(EvalBytes 2 4042)
@ 4201464 NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP
NOP NOP NOP NOP NOP NOP NOP NOP NOP NOP %'0 %'1 %'NIL %'T NOP NOP NOP RETURN))
(* * Special Opcodes)
(RPAQQ testwoct (@ 0 RESET-VMM WRITEOCTNIL.N 32 WRITEOCTUNBOUND.N 32 WRITEOCTNIL.N 24
WRITEOCTUNBOUND.N 24 STOP))
(* * Initialization)
(RPAQQ tamSetUp ((* * 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)
(* * * * * * * UFN TABLE * * * * * * * * * *)
(* * all of the entries of ufn table initially point to a dummy function that just
STOPs)
(EvalBytes 0 (AddAtom 'UfnTable (TamRep 'Int 256)))
[EvalBytes 0 (LET ((codeAddr (TamRep 'Code 512)))
(printout T "loading ufn table..." T)
(for addr from 256 to 511 do (MemoryAccess addr codeAddr T]
(* * the default ufn fn that just STOPs)
(EvalBytes 0 (AddFnHeader 512))
STOP STOP STOP STOP STOP STOP STOP STOP (* 8 bytes unused in this quadword)
(* * * * * * * * ATOMS THAT HOLD THINGS * * * * * * * * *)
(* * UfnTable, above, is an atom whose value is the address of the ufn table as an
Int)
(* * FrameFlagCode is an atom whose function definition just RETNPs)
(EvalBytes 0 (SETQ tamSetUp.FnBase 524))
(EvalBytes 0 (AddAtom 'FrameFlagCode NIL (TamRep 'Code tamSetUp.FnBase)))
(EvalBytes 0 (AddFnHeader tamSetUp.FnBase))
RETEI RETEI RETEI RETEI RETEI RETEI RETEI RETEI (* 8 bytes unused in this quadword)
(* * IntCode is an atom whose function definition just RETEIs)
(EvalBytes 0 (SETQ tamSetUp.FnBase 536))
(EvalBytes 0 (AddAtom 'IntCode NIL (TamRep 'Code tamSetUp.FnBase)))
(EvalBytes 0 (AddFnHeader tamSetUp.FnBase))
RETEI RETEI RETEI RETEI RETEI RETEI RETEI RETEI (* 8 bytes unused in this quadword)
(* * UndefFn is an atom whose function definition just RETURNs)
(EvalBytes 0 (SETQ tamSetUp.FnBase 548))
(EvalBytes 0 (AddAtom 'UndefFn NIL (TamRep 'Code tamSetUp.FnBase)))
(EvalBytes 0 (AddFnHeader tamSetUp.FnBase))
RETURN RETURN RETURN RETURN RETURN RETURN RETURN RETURN (* 8 bytes unused in this
quadword)
(* * PFCode is atom whose function definition is to clear not present bit)
(EvalBytes 0 (SETQ tamSetUp.FnBase 560))
(EvalBytes 0 (AddAtom 'PFCode NIL (TamRep 'Code tamSetUp.FnBase)))
(EvalBytes 0 (AddFnHeader tamSetUp.FnBase))
VAR8 LRSH.N 9 SETTYPE.N (TamTagRep 'Ptr)
COPY GETBASEPTR.N 0 ICONST (EvalBytes 4 (TamRep 511))
LOGAND PUTBASEPTR.N 0 RESET-VMM RETNP (* * * Set VM Table * * *)
(EvalBytes 0 (AddVmTable))
(* 8 bytes unused in this quadword)
(* * TopFrame is atom whose value points to the top stack frame <initial value for
MYCLINK> -- also allocate some frames)
[EvalBytes 0 (AddAtom 'TopFrame (TamRep 'Frame (InitStackFrames 16]
(* * * * * * * * CONS UFN * * * * * * * * *)
(* * just uses the 2 words pointed to by FreeMemIndex, and increments FreeMemIndex)
(EvalBytes 0 (SETQ tamSetUp.FnBase 572))
(EvalBytes 0 (MemoryAccess (IPLUS (CAR (GETPROP 'CONS 'TamarinOp))
(ReadAtom 'UfnTable 'val T))
(TamRep 'Code tamSetUp.FnBase)))
(EvalBytes 0 (AddFnHeader tamSetUp.FnBase))
NOP
(* * first get pointer to val cell of FreeMemIndex and the value itself)
ACONST
(EvalBytes 3 (AddAtom 'FreeMemIndex))
COPY GETBASEPTR.N 1 (* * smash the CAR and CDR into place -- no net stack change)
VAR8 PUTBASEPTR.N 0 VAR9 PUTBASEPTR.N 1 (* * make a copy of old value of
FreeMemIndex, with Listp type bits, and
save it -- no net stack change)
COPY SICX (TamTagRep 'List)
SETSUBTYPE VAR10←↑ (* * increment FreeMemIndex)
SICX 2 ADDBASE PUTBASEPTR.N 1 (* * return the Listp)
VAR10 RETURN (* * * * * * * * * INITIALIZE INTERNAL REGS * * * * * * * *)
(* * 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 'UfnTable 'val]
IREGX←
[CADR (FASSOC 'ufnbase (GETPROP 'k 'uField]
(* * ireg -> FrameFlagCode)
PCONST
(EvalBytes 4 (ReadAtom 'FrameFlagCode 'def))
IREGX←
[CADR (FASSOC 'frameflagcode (GETPROP 'k 'uField]
(* * ireg -> IntCode)
PCONST
(EvalBytes 4 (ReadAtom 'IntCode 'def))
IREGX←
[CADR (FASSOC 'intcode (GETPROP 'k 'uField]
(* * ireg -> UndefFn)
PCONST
(EvalBytes 4 (ReadAtom 'UndefFn 'def))
IREGX←
[CADR (FASSOC 'undeffn (GETPROP 'k 'uField]
(* * ireg -> PFCode)
PCONST
(EvalBytes 4 (ReadAtom 'PFCode 'def))
IREGX←
[CADR (FASSOC 'pfcode (GETPROP 'k 'uField]
(* * done)
STOP))
(RPAQQ tamInit ((* * 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 'TopFrame 'val))
MYCLINK←))
(* * Special Loadups)
(RPAQQ dotak (@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 50))
MYCLINK← SICX 18 SICX 12 SICX 6 FN3 [EvalBytes 3 (AddAtom 'tak NIL
(AddCode 'tak]
STOP))
(RPAQQ dotak2 (@ 0 %'0 VARX← 0 PCONST (EvalBytes 4 (InitStackFrames 20))
MYCLINK← SICX 18 SICX 12 SICX 6 FN3 (EvalBytes 3 (AddAtom 'tak))
(EvalBytes 0 (AddFnHeader 'tak (NextFnAddr)))
VAR8 COPY VAR9 GREATERP TJUMP2 VAR10 RETURN %'1 DIFFERENCE VAR9 VAR10 FN3
(EvalBytes 3 (AddAtom 'tak))
VAR9 %'1 DIFFERENCE VAR10 VAR8 FN3 (EvalBytes 3 (AddAtom 'tak))
VAR10 %'1 DIFFERENCE VAR8 VAR9 FN3 (EvalBytes 3 (AddAtom 'tak))
VAR10← POP VAR9← POP VAR8← NJUMPX 39 NOP RETURN STOP))
(DEFINEQ
(Testfn
[LAMBDA (Arg) (* rtk "19-May-86 13:30")
(PLUS Arg 1])
(tak
[LAMBDA (x y z) (* rtk "10-Jun-86 10:08")
(COND
((NOT (LESSP y x))
z)
(T (tak (tak (SUB1 x)
y z)
(tak (SUB1 y)
z x)
(tak (SUB1 z)
x y])
)
(PUTPROPS TESTOPS COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (80920 81387 (Testfn 80930 . 81054) (tak 81056 . 81385)))))
STOP