diff --git a/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL b/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL index e472fe52..d25a53ff 100644 Binary files a/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL and b/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL differ diff --git a/internal/test/Maiko/ARs/optests.dfasl b/internal/test/Maiko/ARs/optests.dfasl index 4e225a77..8895f278 100644 Binary files a/internal/test/Maiko/ARs/optests.dfasl and b/internal/test/Maiko/ARs/optests.dfasl differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL b/internal/test/Maiko/AUTO/OPCODES.DFASL index 468a3799..a7cc1b76 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL and b/internal/test/Maiko/AUTO/OPCODES.DFASL differ diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST b/internal/test/Maiko/AUTO/OPCODES.TEST index e4195bd2..2075d79d 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST +++ b/internal/test/Maiko/AUTO/OPCODES.TEST @@ -1,500 +1,11 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "16-Nov-88 18:02:22" {ERIS}MAIKO>AUTO>OPCODES.TEST\;10 96285 - - |changes| |to:| (FNS UNWINDTESTER CLOSUREMAINTEST ADDR-IN-RANGE) - (FUNCTIONS SLOPED-LINES DIAGONALS SIMULATE-PILOTBITBLT BUMP - XCL-USER::COPY.N.TEST XCL-USER::STORE.N.TEST XCL-USER::POP.N.TEST) - (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER) - (TESTS ERROR+ ERROR/T ERROR/0 NO-ERROR-0/0) - (VARS OPCODESCOMS) - - |previous| |date:| "16-Nov-88 16:38:34" {ERIS}MAIKO>AUTO>OPCODES.TEST\;9) - - -; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. - -(PRETTYCOMPRINT OPCODESCOMS) - -(RPAQQ OPCODESCOMS - ( - (* |;;| "This file contains tests for the various opcodes used in the system.") - - (VARS (*TEST-FILE-NAME* "OPCODES")) - (COMS (* \; "BITBLT") - (FUNCTIONS SIMULATE-PILOTBITBLT BUMP) - (FUNCTIONS SLOPED-LINES DIAGONALS) - (FNS ADDR-IN-RANGE) - (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) - (COMS (* \; "COPY.N") - (FUNCTIONS XCL-USER::COPY.N.TEST) - (TESTS COPY.N COPY.N-UFN)) - (COMS (* \; "STORE.N") - (FUNCTIONS XCL-USER::STORE.N.TEST) - (TESTS STORE.N STORE.N-UFN)) - (COMS (* \; "POP.N") - (FUNCTIONS XCL-USER::POP.N.TEST) - (TESTS POP.N POP.N-UFN)) - (COMS (* \; "UNWIND") - (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) - (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 - UNWINDCODE) - (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) - (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) - (TESTS UNWIND UNWIND-2)) - (COMS (* \; "FINDKEY") - (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) - (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) - (TESTS FINDKEY)) - (COMS (* \; "RESTLIST") - (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS - DORESTLISTTEST1) - (INITVARS (RESTLISTCOUNTER 0)) - (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) - (RECORDS MDSTYPEWORD) - (GLOBALVARS RESTLISTCOUNTER)) - (TESTS RESTLIST)) - (COMS (* \; "Closure tests") - (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK - CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE - CLOSUREFN4CODE CLOSUREFN4VALUE) - (INITVARS (CLOSURETEST.DEPTH 50) - (CLOSURETEST.ENVIRONMENT "Closure Environment")) - (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) - (TESTS CLOSURES)) - (COMS (* \; "Free-variable lookup") - (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) - (TESTS FREE-VAR-LOOKUP)) - (COMS (* \; "AREF opcode tests") - (VARS (*NON-CONSTANT-FLOAT-1* 1.0)) - (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD - XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP - XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER - XCL-USER::AREF1-PUNT) - - (* |;;| "array-read and array-write ") - - (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE - XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD - XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP - XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR - XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) - (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE - XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD - XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP - XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR - XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) - (COMS - (* |;;| "Boxed opcodes") - - (VARS (*NON-CONSTANT-T* T) - (*NON-CONSTANT-0* 0)) - (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) - (TESTS ERROR+) - (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) - (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) - (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) - (TESTS ERROR/T ERROR/0 NO-ERROR-0/0) - (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) - (COMS - (* |;;| "Unboxed opcodes [scalar]") - - - (* |;;| "Ubfloat1") - - (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS - XCL-USER::UBNEGATE XCL-USER::UBFIX) - - (* |;;| "Ubfloat2") - - (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ - XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) - - (* |;;| "Ubfloat3") - - (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) - (COMS - (* |;;| "Transcendentals --- stress test") - - (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST - XCL-USER::LOG-TEST)) - (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA DORESTLISTTEST - DOFINDKEYTEST))))) - - - -(* |;;| "This file contains tests for the various opcodes used in the system.") - - -(RPAQ *TEST-FILE-NAME* "OPCODES") - - - -(* \; "BITBLT") - - -(CL:DEFUN SIMULATE-PILOTBITBLT (BBT LOW-WORD-ADDR HI-WORD-ADDR) - - (* |;;| "A translation of the algorithm in the Mesa PrincOps.") - - (* |;;| " S-L-O-W !!!") - - (LET ((SRC.WORD (FETCH (PILOTBBT PBTSOURCE) OF BBT)) - (SRC.BIT (FETCH (PILOTBBT PBTSOURCEBIT) OF BBT)) - (SRC.BPL (FETCH (PILOTBBT PBTSOURCEBPL) OF BBT)) - (DST.WORD (FETCH (PILOTBBT PBTDEST) OF BBT)) - (DST.BIT (FETCH (PILOTBBT PBTDESTBIT) OF BBT)) - (DST.BPL (FETCH (PILOTBBT PBTDESTBPL) OF BBT)) - (BBT.WIDTH (FETCH (PILOTBBT PBTWIDTH) OF BBT)) - (BBT.HEIGHT (FETCH (PILOTBBT PBTHEIGHT) OF BBT)) - (BOOL-OP (LET ((COMPLEMENT? (NOT (CL:ZEROP (FETCH (PILOTBBT PBTSOURCETYPE) OF BBT))) - )) - (CL:ECASE (FETCH (PILOTBBT PBTOPERATION) OF BBT) - ((0) (CL:IF COMPLEMENT? - CL:BOOLE-C1 - CL:BOOLE-1)) - ((1) (CL:IF COMPLEMENT? - CL:BOOLE-ANDC1 - CL:BOOLE-AND)) - ((2) (CL:IF COMPLEMENT? - CL:BOOLE-ORC1 - CL:BOOLE-IOR)) - ((3) (CL:IF COMPLEMENT? - CL:BOOLE-EQV - CL:BOOLE-XOR))))) - (GRAY? (FETCH (PILOTBBT PBTUSEGRAY) OF BBT)) - (GRAY.WIDTH (ITIMES (ADD1 (FETCH (PILOTBBT PBTGRAYWIDTHLESSONE) OF BBT)) - 16)) - (GRAY.HEIGHT (ADD1 (FETCH (PILOTBBT PBTGRAYHEIGHTLESSONE) OF BBT))) - LINE GRAY.BUMP LAST-GRAY Y-FORWARD? X-FORWARD?) - (CL:LABELS ((MODIFY-BIT (DSTWORD DSTBIT DSTOFFSET SRCWORD SRCBIT SRCOFFSET) - (CL:MULTIPLE-VALUE-BIND (SRCWORD SRCBIT) - (BUMP SRCWORD SRCBIT SRCOFFSET) - (CL:MULTIPLE-VALUE-BIND (DSTWORD DSTBIT) - (BUMP DSTWORD DSTBIT DSTOFFSET) - (ADDR-IN-RANGE LOW-WORD-ADDR DSTWORD HI-WORD-ADDR) - (CL:SETF (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) - (GETBASE DSTWORD 0)) - (CL:BOOLE BOOL-OP (LDB (BYTE 1 (IDIFFERENCE 15 SRCBIT - )) - (GETBASE SRCWORD 0)) - (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) - (GETBASE DSTWORD 0))))))) - (BITBLT-ITEM NIL - (LET ((OFFSET (CL:IF X-FORWARD? - 0 - (SUB1 BBT.WIDTH)))) - (FRPTQ BBT.WIDTH - (LET ((POS (CL:IF GRAY? - (IDIFFERENCE (IMOD (IPLUS OFFSET SRC.BIT) - (ABS GRAY.WIDTH)) - SRC.BIT) - OFFSET))) - (MODIFY-BIT DST.WORD DST.BIT OFFSET SRC.WORD SRC.BIT POS) - ) - (CL:INCF OFFSET (CL:IF X-FORWARD? - 1 - -1))))) - (SETUP NIL (CL:WHEN GRAY? - (SETQ GRAY.BUMP (IMINUS (ITIMES GRAY.WIDTH (SUB1 GRAY.HEIGHT))))) - (COMPUTE-DIRECTION) - (CL:WHEN GRAY? - (SETQ LAST-GRAY (CL:IF Y-FORWARD? - (IDIFFERENCE GRAY.HEIGHT 1 (FETCH (PILOTBBT - - PBTGRAYOFFSET - ) - OF BBT)) - (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)))) - (SETQ LINE (CL:IF Y-FORWARD? - 0 - (SUB1 BBT.HEIGHT)))) - (COMPUTE-DIRECTION NIL (SETQ Y-FORWARD? (SETQ X-FORWARD? - (NOT (FETCH (PILOTBBT PBTBACKWARD) - OF BBT)))))) - (SETUP) - (WHILE (AND (ILEQ 0 LINE) - (ILESSP LINE BBT.HEIGHT)) - DO (BITBLT-ITEM) - (BLOCK) (* \; "just to be nice.") - (CL:MULTIPLE-VALUE-SETQ (SRC.WORD SRC.BIT) - (BUMP SRC.WORD SRC.BIT (CL:IF GRAY? - (CL:IF (= (IMOD LINE GRAY.HEIGHT) - LAST-GRAY) - GRAY.BUMP - GRAY.WIDTH) - SRC.BPL))) - (CL:MULTIPLE-VALUE-SETQ (DST.WORD DST.BIT) - (BUMP DST.WORD DST.BIT DST.BPL)) - (CL:INCF LINE (CL:IF Y-FORWARD? - 1 - -1)))))) - -(CL:DEFUN BUMP (WORD BIT INCR) - (CL:MULTIPLE-VALUE-BIND (WORD-INCR NEW-BIT) - (CL:FLOOR (IPLUS BIT INCR) - 16) - (CL:VALUES (ADDBASE WORD WORD-INCR) - NEW-BIT))) - -(CL:DEFUN SLOPED-LINES (W) - (LET* ((FEEDBACK-INTERVAL (QUOTIENT W 20)) - (NEXT-FEEDBACK 0) - (BLACK #16*1) - (A (CL:MAKE-ARRAY (LIST W W) - :ELEMENT-TYPE - 'BIT :INITIAL-ELEMENT 0)) - (DA (CL:MAKE-ARRAY (ITIMES W W) - :ELEMENT-TYPE - 'BIT :DISPLACED-TO A)) - (R (CL:MAKE-ARRAY (LIST W W) - :ELEMENT-TYPE - 'BIT :INITIAL-ELEMENT 0)) - (LOW-ADDR (FETCH (ARRAY-HEADER BASE) OF R)) - (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) - 16)))) - (DR (CL:MAKE-ARRAY (ITIMES W W) - :ELEMENT-TYPE - 'BIT :DISPLACED-TO R)) - (BBT (CREATE PILOTBBT - PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF A) - PBTDESTBIT _ 0 - PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) - PBTSOURCEBIT _ 0 - PBTGRAYOFFSET _ 0 - PBTGRAYWIDTHLESSONE _ 0 - PBTGRAYHEIGHTLESSONE _ 0 - PBTWIDTH _ 0 - PBTDISJOINT _ T - PBTUSEGRAY _ T))) - (CL:DOTIMES (SLOPE W) - (CL:WHEN (> SLOPE NEXT-FEEDBACK) - (CL:PRINC #\. *ERROR-OUTPUT*) - (CL:INCF NEXT-FEEDBACK FEEDBACK-INTERVAL)) - (CL:FILL DA 0) - (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH (IPLUS W SLOPE 1)) - (CL:INCF (FETCH (PILOTBBT PBTWIDTH) OF BBT)) - (REPLACE (PILOTBBT PBTHEIGHT) OF BBT WITH (CL:CEILING W (ADD1 SLOPE))) - (\\PILOTBITBLT BBT NIL) - (CL:FILL DR 0) - (SIMULATE-PILOTBITBLT (CREATE PILOTBBT USING BBT PBTDEST _ (FETCH - (ARRAY-HEADER BASE) - OF R)) - LOW-ADDR HI-ADDR) - (CL:WHEN (NOT (CL:EQUAL DA DR)) - (CL:CERROR "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" W SLOPE))))) - -(CL:DEFUN DIAGONALS (W SKIP-SIMULATION SKIP-UCODE) - - (* |;;| "Draw both diagonals in a square of size W.") - - (* |;;| - "if SKIP-SIMULATION is not NIL, don't bother with the simulation or a consistency check.") - - (* |;;| - "if SKIP-UCODE is not NIL, don't bother with the real microcode version or a consistency check.") - - (LET* ((FAILURES NIL) - (BLACK #16*1) - (A (CL:MAKE-ARRAY (LIST W W) - :ELEMENT-TYPE - 'BIT :INITIAL-ELEMENT 0)) - (A-BASE (FETCH (ARRAY-HEADER BASE) OF A)) - (DA (CL:MAKE-ARRAY (ITIMES W W) - :ELEMENT-TYPE - 'BIT :DISPLACED-TO A)) - (R (CL:MAKE-ARRAY (LIST W W) - :ELEMENT-TYPE - 'BIT :INITIAL-ELEMENT 0)) - (R-BASE (FETCH (ARRAY-HEADER BASE) OF R)) - (LOW-ADDR R-BASE) - (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) - 16)))) - (DR (CL:MAKE-ARRAY (ITIMES W W) - :ELEMENT-TYPE - 'BIT :DISPLACED-TO R)) - (BBT (CREATE PILOTBBT - PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) - PBTSOURCEBIT _ 0 - PBTGRAYOFFSET _ 0 - PBTGRAYWIDTHLESSONE _ 0 - PBTGRAYHEIGHTLESSONE _ 0 - PBTWIDTH _ 1 - PBTHEIGHT _ W - PBTDISJOINT _ T - PBTUSEGRAY _ T))) - (CL:MACROLET ((CLEAR (WHICH) - `(CL:FILL ,WHICH 0))) - (CL:LABELS ((SET-SOURCE (BBT BASE INCREMENT) - (CL:MULTIPLE-VALUE-BIND (WORD BIT) - (BUMP BASE 0 INCREMENT) - (REPLACE (PILOTBBT PBTDEST) OF BBT WITH WORD) - (REPLACE (PILOTBBT PBTDESTBIT) OF BBT WITH - BIT)) - BBT) - (CHECK-RESULT (FROM TO START-OFFSET) - (CLEAR DR) - (CL:UNLESS SKIP-SIMULATION - - (* |;;| "Only run this if we need the simulation.") - - (SIMULATE-PILOTBITBLT (SET-SOURCE (CREATE PILOTBBT - USING BBT) - R-BASE START-OFFSET) - LOW-ADDR HI-ADDR)) - (CL:UNLESS (OR SKIP-SIMULATION SKIP-UCODE) - - (* |;;| "Only check the results if we ran both versions.") - - (CL:WHEN (NOT (CL:EQUAL DA DR)) - (CL:PUSH (CL:CONCATENATE 'STRING FROM " to " TO) - FAILURES) - (CL:CERROR "Try the next one" - "Bad BITBLT: ~A to ~A diagonal w: ~D " FROM TO W))) - ) - (DO-ONE (FROM TO START-OFFSET BPL) - (CLEAR DA) - (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH BPL) - (REPLACE (PILOTBBT PBTBACKWARD) OF BBT - WITH (ILESSP BPL 0)) - (OR SKIP-UCODE (\\PILOTBITBLT (SET-SOURCE BBT A-BASE START-OFFSET) - NIL)) - (CHECK-RESULT FROM TO START-OFFSET))) - (DO-ONE "upper left" "lower right" 0 (ADD1 W)) - (DO-ONE "upper right" "lower left" (SUB1 W) - (SUB1 W)) - (DO-ONE "lower left" "upper right" (ITIMES W (SUB1 W)) - (IMINUS (SUB1 W))) - (DO-ONE "lower right" "upper left" (SUB1 (ITIMES W W)) - (IMINUS (ADD1 W))))) - (CL:VALUES (NOT FAILURES) - FAILURES))) -(DEFINEQ - -(ADDR-IN-RANGE -(LAMBDA (LOW ADDR HI) (* \; "Edited 16-Nov-88 14:32 by jds") (OR (<= (+ (LLSH (HILOC LOW) 16) (LOLOC LOW)) (+ (LLSH (HILOC ADDR) 16) (LOLOC ADDR)) (+ (LLSH (HILOC HI) 16) (LOLOC HI))) (HELP))) -) -) - -(DEFTEST (BITBLT-DIAGONALS :COMPILED) - (FOR WIDTH - IN '(1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41) ALWAYS (PRINT WIDTH) - (* \; "DD") - (DIAGONALS WIDTH))) - -(DEFTEST (BITBLT-SLOPED-LINES :COMPILED) - (FOR I IN '(1 3 4 5 7 8 9 15 16 17) DO (SLOPED-LINES I)) - T) - - - -(* \; "COPY.N") - - -(CL:DEFUN XCL-USER::COPY.N.TEST (XCL-USER::USE-UFN) - "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" - (CL:IF XCL-USER::USE-UFN - (PROGN ((OPCODES COPY) - 2 1 :OK -1 -2) - (CL:FUNCALL (\\GETUFNENTRY 'COPY.N) - 4)) - ((OPCODES COPY.N 4) - 2 1 :OK -1 -2))) - -(DEFTEST (COPY.N :COMPILED) - - (* |;;| "COPY.N opcode") - - (EQ :OK (XCL-USER::COPY.N.TEST))) - -(DEFTEST COPY.N-UFN - (EQ :OK (XCL-USER::COPY.N.TEST T))) - - - -(* \; "STORE.N") - - -(CL:DEFUN XCL-USER::STORE.N.TEST (XCL-USER::USE-UFN) - "Tests a case of the STORE.N opcode. Both (STORE.N.TEST NIL) and (STORE.N.TEST T) should return the list (5 4 t 2 1)" - (CL:IF XCL-USER::USE-UFN - (PROGN ((OPCODES COPY) - 5 4 3 2 1) - (CL:FUNCALL (\\GETUFNENTRY 'STORE.N) - T 4)) - ((OPCODES STORE.N 4) - 5 4 3 2 1 T)) - ((OPCODES APPLYFN) - 5 - 'LIST)) - -(DEFTEST (STORE.N :COMPILED) - - (* |;;| "COPY.N opcode") - - (EQUAL '(5 4 T 2 1) - (XCL-USER::STORE.N.TEST))) - -(DEFTEST STORE.N-UFN - - (* |;;| "STORE.N opcode") - - (EQUAL '(5 4 T 2 1) - (XCL-USER::STORE.N.TEST T))) - - - -(* \; "POP.N") - - -(CL:DEFUN XCL-USER::POP.N.TEST (XCL-USER::USE-UFN) - "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" - (CL:IF XCL-USER::USE-UFN - (PROGN ((OPCODES COPY) - 4 3 2 1 0) - (CL:FUNCALL (\\GETUFNENTRY 'POP.N) - 2)) - ((OPCODES POP.N 2) - 4 3 2 1 0))) - -(DEFTEST (POP.N :COMPILED) - (= 3 (XCL-USER::POP.N.TEST))) - -(DEFTEST POP.N-UFN - (= 3 (XCL-USER::POP.N.TEST T))) - - - -(* \; "UNWIND") - - -(DEFTEST UNWIND-OFF-BY-1-A - (LET ((F CL:PI)) - (EQUAL (LIST 'SUCCESS (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) - F)) - '(SUCCESS 3.1415927)))) - -(DEFTEST UNWIND-OFF-BY-1-B - - (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") - - (LET ((F CL:PI)) - (|for| C |in| (UNPACK F) |do| (PRIN1 C)) - (AND (FLOATP F) - (= F CL:PI)))) -(DEFINEQ - -(UNWINDTESTER +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "17-Dec-2020 18:44:48"  |{DSK}larry>ilisp>medley>internal>test>Maiko>AUTO>OPCODES.TEST;2| 96400 |changes| |to:| (VARS OPCODESCOMS) (FNS ADDR-IN-RANGE) (FUNCTIONS SIMULATE-PILOTBITBLT BUMP SLOPED-LINES DIAGONALS) |previous| |date:| "16-Nov-88 18:02:22" |{DSK}larry>ilisp>medley>internal>test>Maiko>AUTO>OPCODES.TEST;1|) ; Copyright (c) 1988, 2020 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT OPCODESCOMS) (RPAQQ OPCODESCOMS ( (* |;;| "This file contains tests for the various opcodes used in the system.") (DECLARE\: EVAL@COMPILE (FILES DO-TEST)) (VARS (*TEST-FILE-NAME* "OPCODES")) (COMS (* \; "BITBLT") (FUNCTIONS SIMULATE-PILOTBITBLT BUMP) (FUNCTIONS SLOPED-LINES DIAGONALS) (FNS ADDR-IN-RANGE) (TESTS BITBLT-DIAGONALS BITBLT-SLOPED-LINES)) (COMS (* \; "COPY.N") (FUNCTIONS XCL-USER::COPY.N.TEST) (TESTS COPY.N COPY.N-UFN)) (COMS (* \; "STORE.N") (FUNCTIONS XCL-USER::STORE.N.TEST) (TESTS STORE.N STORE.N-UFN)) (COMS (* \; "POP.N") (FUNCTIONS XCL-USER::POP.N.TEST) (TESTS POP.N POP.N-UFN)) (COMS (* \; "UNWIND") (TESTS UNWIND-OFF-BY-1-A UNWIND-OFF-BY-1-B) (FNS UNWINDTESTER UNWINDMAINTEST UNWINDMAINTEST.RECURSE UNWINDCHECK1 UNWINDCHECK2 UNWINDCODE) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS BINDMARKSLOT)) (FNS UW2.TEST UW2.RECURSE UW2.TEST.MAIN UW2.CHECK UW2.IDENTITY) (TESTS UNWIND UNWIND-2)) (COMS (* \; "FINDKEY") (FNS FINDKEYTESTER DOFINDKEYTEST DOFINDKEYTEST1) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS FINDKEYCHECK)) (TESTS FINDKEY)) (COMS (* \; "RESTLIST") (FNS \\RESTLIST.SPLICE.FRAME RESTLISTTESTER DORESTLISTTEST GETRESTARGREFCNTS DORESTLISTTEST1) (INITVARS (RESTLISTCOUNTER 0)) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS RESTLISTCHECK \\COMPUTED.FORM) (RECORDS MDSTYPEWORD) (GLOBALVARS RESTLISTCOUNTER)) (TESTS RESTLIST)) (COMS (* \; "Closure tests") (FNS CLOSURETESTER CLOSUREMAINTEST CLOSUREMAINTEST.RECURSE CLOSUREFNCHECK CLOSUREFNCHECK2 CLOSUREFN1 CLOSUREFN1VALUE CLOSUREFN2 CLOSUREFN2VALUE CLOSUREFN4CODE CLOSUREFN4VALUE) (INITVARS (CLOSURETEST.DEPTH 50) (CLOSURETEST.ENVIRONMENT "Closure Environment")) (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) (TESTS CLOSURES)) (COMS (* \; "Free-variable lookup") (FNS FVARTEST0 FVARTEST1 FVARTEST2 FVARTEST3) (TESTS FREE-VAR-LOOKUP)) (COMS (* \; "AREF opcode tests") (VARS (*NON-CONSTANT-FLOAT-1* 1.0)) (XCL-USER::VERIFIED-TESTS XCL-USER::AREF1-BIT XCL-USER::AREF1-BYTE XCL-USER::AREF1-WORD XCL-USER::AREF1-SIGNED-WORD XCL-USER::AREF1-FIXP XCL-USER::AREF1-FLOATP XCL-USER::AREF1-STRING-CHAR XCL-USER::AREF1-POINTER XCL-USER::AREF1-XPOINTER XCL-USER::AREF1-PUNT) (* |;;| "array-read and array-write ") (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-READ-BIT XCL-USER::ARRAY-READ-BYTE XCL-USER::ARRAY-READ-WORD XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::ARRAY-READ-FIXP XCL-USER::ARRAY-READ-FLOATP XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::ARRAY-READ-POINTER XCL-USER::ARRAY-READ-XPOINTER) (XCL-USER::VERIFIED-TESTS XCL-USER::ARRAY-WRITE-BIT XCL-USER::ARRAY-WRITE-BYTE XCL-USER::ARRAY-WRITE-WORD XCL-USER::ARRAY-WRITE-SIGNED-WORD XCL-USER::ARRAY-WRITE-FIXP XCL-USER::ARRAY-WRITE-FLOATP XCL-USER::ARRAY-WRITE-THIN-CHAR XCL-USER::ARRAY-WRITE-FAT-CHAR XCL-USER::ARRAY-WRITE-POINTER XCL-USER::ARRAY-WRITE-XPOINTER)) (COMS (* |;;| "Boxed opcodes") (VARS (*NON-CONSTANT-T* T) (*NON-CONSTANT-0* 0)) (XCL-USER::VERIFIED-TESTS XCL-USER::INT+ XCL-USER::FLOAT+ XCL-USER::MIXED+) (TESTS ERROR+) (XCL-USER::VERIFIED-TESTS XCL-USER::INT- XCL-USER::FLOAT- XCL-USER::MIXED-) (XCL-USER::VERIFIED-TESTS XCL-USER::INT* XCL-USER::FLOAT* XCL-USER::MIXED*) (XCL-USER::VERIFIED-TESTS XCL-USER::INT/ XCL-USER::FLOAT/ XCL-USER::MIXED/) (TESTS ERROR/T ERROR/0 NO-ERROR-0/0) (XCL-USER::VERIFIED-TESTS XCL-USER::INT> XCL-USER::FLOAT> XCL-USER::MIXED>)) (COMS (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::VERIFIED-TESTS XCL-USER::BOX XCL-USER::UNBOX XCL-USER::UBABS XCL-USER::UBNEGATE XCL-USER::UBFIX) (* |;;| "Ubfloat2") (XCL-USER::VERIFIED-TESTS XCL-USER::UB+ XCL-USER::UB- XCL-USER::UB* XCL-USER::UB/ XCL-USER::UB> XCL-USER::UBMAX XCL-USER::UBMIN) (* |;;| "Ubfloat3") (XCL-USER::VERIFIED-TESTS XCL-USER::POLY)) (COMS (* |;;| "Transcendentals --- stress test") (XCL-USER::VERIFIED-TESTS XCL-USER::SIN-TEST XCL-USER::COS-TEST XCL-USER::EXP-TEST XCL-USER::LOG-TEST)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA DORESTLISTTEST DOFINDKEYTEST))))) (* |;;| "This file contains tests for the various opcodes used in the system.") (DECLARE\: EVAL@COMPILE (FILESLOAD DO-TEST) ) (RPAQ *TEST-FILE-NAME* "OPCODES") (* \; "BITBLT") (CL:DEFUN SIMULATE-PILOTBITBLT (BBT LOW-WORD-ADDR HI-WORD-ADDR) (* |;;| "A translation of the algorithm in the Mesa PrincOps.") (* |;;| " S-L-O-W !!!") (LET ((SRC.WORD (FETCH (PILOTBBT PBTSOURCE) OF BBT)) (SRC.BIT (FETCH (PILOTBBT PBTSOURCEBIT) OF BBT)) (SRC.BPL (FETCH (PILOTBBT PBTSOURCEBPL) OF BBT)) (DST.WORD (FETCH (PILOTBBT PBTDEST) OF BBT)) (DST.BIT (FETCH (PILOTBBT PBTDESTBIT) OF BBT)) (DST.BPL (FETCH (PILOTBBT PBTDESTBPL) OF BBT)) (BBT.WIDTH (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (BBT.HEIGHT (FETCH (PILOTBBT PBTHEIGHT) OF BBT)) (BOOL-OP (LET ((COMPLEMENT? (NOT (CL:ZEROP (FETCH (PILOTBBT PBTSOURCETYPE) OF BBT))) )) (CL:ECASE (FETCH (PILOTBBT PBTOPERATION) OF BBT) ((0) (CL:IF COMPLEMENT? CL:BOOLE-C1 CL:BOOLE-1)) ((1) (CL:IF COMPLEMENT? CL:BOOLE-ANDC1 CL:BOOLE-AND)) ((2) (CL:IF COMPLEMENT? CL:BOOLE-ORC1 CL:BOOLE-IOR)) ((3) (CL:IF COMPLEMENT? CL:BOOLE-EQV CL:BOOLE-XOR))))) (GRAY? (FETCH (PILOTBBT PBTUSEGRAY) OF BBT)) (GRAY.WIDTH (ITIMES (ADD1 (FETCH (PILOTBBT PBTGRAYWIDTHLESSONE) OF BBT)) 16)) (GRAY.HEIGHT (ADD1 (FETCH (PILOTBBT PBTGRAYHEIGHTLESSONE) OF BBT))) LINE GRAY.BUMP LAST-GRAY Y-FORWARD? X-FORWARD?) (CL:LABELS ((MODIFY-BIT (DSTWORD DSTBIT DSTOFFSET SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (SRCWORD SRCBIT) (BUMP SRCWORD SRCBIT SRCOFFSET) (CL:MULTIPLE-VALUE-BIND (DSTWORD DSTBIT) (BUMP DSTWORD DSTBIT DSTOFFSET) (ADDR-IN-RANGE LOW-WORD-ADDR DSTWORD HI-WORD-ADDR) (CL:SETF (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0)) (CL:BOOLE BOOL-OP (LDB (BYTE 1 (IDIFFERENCE 15 SRCBIT )) (GETBASE SRCWORD 0)) (LDB (BYTE 1 (IDIFFERENCE 15 DSTBIT)) (GETBASE DSTWORD 0))))))) (BITBLT-ITEM NIL (LET ((OFFSET (CL:IF X-FORWARD? 0 (SUB1 BBT.WIDTH)))) (FRPTQ BBT.WIDTH (LET ((POS (CL:IF GRAY? (IDIFFERENCE (IMOD (IPLUS OFFSET SRC.BIT) (ABS GRAY.WIDTH)) SRC.BIT) OFFSET))) (MODIFY-BIT DST.WORD DST.BIT OFFSET SRC.WORD SRC.BIT POS) ) (CL:INCF OFFSET (CL:IF X-FORWARD? 1 -1))))) (SETUP NIL (CL:WHEN GRAY? (SETQ GRAY.BUMP (IMINUS (ITIMES GRAY.WIDTH (SUB1 GRAY.HEIGHT))))) (COMPUTE-DIRECTION) (CL:WHEN GRAY? (SETQ LAST-GRAY (CL:IF Y-FORWARD? (IDIFFERENCE GRAY.HEIGHT 1 (FETCH (PILOTBBT PBTGRAYOFFSET ) OF BBT)) (FETCH (PILOTBBT PBTGRAYOFFSET) OF BBT)))) (SETQ LINE (CL:IF Y-FORWARD? 0 (SUB1 BBT.HEIGHT)))) (COMPUTE-DIRECTION NIL (SETQ Y-FORWARD? (SETQ X-FORWARD? (NOT (FETCH (PILOTBBT PBTBACKWARD) OF BBT)))))) (SETUP) (WHILE (AND (ILEQ 0 LINE) (ILESSP LINE BBT.HEIGHT)) DO (BITBLT-ITEM) (BLOCK) (* \; "just to be nice.") (CL:MULTIPLE-VALUE-SETQ (SRC.WORD SRC.BIT) (BUMP SRC.WORD SRC.BIT (CL:IF GRAY? (CL:IF (= (IMOD LINE GRAY.HEIGHT) LAST-GRAY) GRAY.BUMP GRAY.WIDTH) SRC.BPL))) (CL:MULTIPLE-VALUE-SETQ (DST.WORD DST.BIT) (BUMP DST.WORD DST.BIT DST.BPL)) (CL:INCF LINE (CL:IF Y-FORWARD? 1 -1)))))) (CL:DEFUN BUMP (WORD BIT INCR) (CL:MULTIPLE-VALUE-BIND (WORD-INCR NEW-BIT) (CL:FLOOR (IPLUS BIT INCR) 16) (CL:VALUES (ADDBASE WORD WORD-INCR) NEW-BIT))) (CL:DEFUN SLOPED-LINES (W) (LET* ((FEEDBACK-INTERVAL (QUOTIENT W 20)) (NEXT-FEEDBACK 0) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (LOW-ADDR (FETCH (ARRAY-HEADER BASE) OF R)) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF A) PBTDESTBIT _ 0 PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 0 PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:DOTIMES (SLOPE W) (CL:WHEN (> SLOPE NEXT-FEEDBACK) (CL:PRINC #\. *ERROR-OUTPUT*) (CL:INCF NEXT-FEEDBACK FEEDBACK-INTERVAL)) (CL:FILL DA 0) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH (IPLUS W SLOPE 1)) (CL:INCF (FETCH (PILOTBBT PBTWIDTH) OF BBT)) (REPLACE (PILOTBBT PBTHEIGHT) OF BBT WITH (CL:CEILING W (ADD1 SLOPE))) (\\PILOTBITBLT BBT NIL) (CL:FILL DR 0) (SIMULATE-PILOTBITBLT (CREATE PILOTBBT USING BBT PBTDEST _ (FETCH (ARRAY-HEADER BASE) OF R)) LOW-ADDR HI-ADDR) (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:CERROR "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" W SLOPE))))) (CL:DEFUN DIAGONALS (W SKIP-SIMULATION SKIP-UCODE) (* |;;| "Draw both diagonals in a square of size W.") (* |;;|  "if SKIP-SIMULATION is not NIL, don't bother with the simulation or a consistency check.") (* |;;|  "if SKIP-UCODE is not NIL, don't bother with the real microcode version or a consistency check.") (LET* ((FAILURES NIL) (BLACK #16*1) (A (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (A-BASE (FETCH (ARRAY-HEADER BASE) OF A)) (DA (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO A)) (R (CL:MAKE-ARRAY (LIST W W) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)) (R-BASE (FETCH (ARRAY-HEADER BASE) OF R)) (LOW-ADDR R-BASE) (HI-ADDR (\\ADDBASE LOW-ADDR (SUB1 (IQUOTIENT (+ 15 (ITIMES W W)) 16)))) (DR (CL:MAKE-ARRAY (ITIMES W W) :ELEMENT-TYPE 'BIT :DISPLACED-TO R)) (BBT (CREATE PILOTBBT PBTSOURCE _ (FETCH (ARRAY-HEADER BASE) OF BLACK) PBTSOURCEBIT _ 0 PBTGRAYOFFSET _ 0 PBTGRAYWIDTHLESSONE _ 0 PBTGRAYHEIGHTLESSONE _ 0 PBTWIDTH _ 1 PBTHEIGHT _ W PBTDISJOINT _ T PBTUSEGRAY _ T))) (CL:MACROLET ((CLEAR (WHICH) `(CL:FILL ,WHICH 0))) (CL:LABELS ((SET-SOURCE (BBT BASE INCREMENT) (CL:MULTIPLE-VALUE-BIND (WORD BIT) (BUMP BASE 0 INCREMENT) (REPLACE (PILOTBBT PBTDEST) OF BBT WITH WORD) (REPLACE (PILOTBBT PBTDESTBIT) OF BBT WITH BIT)) BBT) (CHECK-RESULT (FROM TO START-OFFSET) (CLEAR DR) (CL:UNLESS SKIP-SIMULATION (* |;;| "Only run this if we need the simulation.") (SIMULATE-PILOTBITBLT (SET-SOURCE (CREATE PILOTBBT USING BBT) R-BASE START-OFFSET) LOW-ADDR HI-ADDR)) (CL:UNLESS (OR SKIP-SIMULATION SKIP-UCODE) (* |;;| "Only check the results if we ran both versions.") (CL:WHEN (NOT (CL:EQUAL DA DR)) (CL:PUSH (CL:CONCATENATE 'STRING FROM " to " TO) FAILURES) (CL:CERROR "Try the next one" "Bad BITBLT: ~A to ~A diagonal w: ~D " FROM TO W))) ) (DO-ONE (FROM TO START-OFFSET BPL) (CLEAR DA) (REPLACE (PILOTBBT PBTDESTBPL) OF BBT WITH BPL) (REPLACE (PILOTBBT PBTBACKWARD) OF BBT WITH (ILESSP BPL 0)) (OR SKIP-UCODE (\\PILOTBITBLT (SET-SOURCE BBT A-BASE START-OFFSET) NIL)) (CHECK-RESULT FROM TO START-OFFSET))) (DO-ONE "upper left" "lower right" 0 (ADD1 W)) (DO-ONE "upper right" "lower left" (SUB1 W) (SUB1 W)) (DO-ONE "lower left" "upper right" (ITIMES W (SUB1 W)) (IMINUS (SUB1 W))) (DO-ONE "lower right" "upper left" (SUB1 (ITIMES W W)) (IMINUS (ADD1 W))))) (CL:VALUES (NOT FAILURES) FAILURES))) (DEFINEQ (ADDR-IN-RANGE (LAMBDA (LOW ADDR HI) (* \; "Edited 16-Nov-88 14:32 by jds") (OR (<= (+ (LLSH (HILOC LOW) 16) (LOLOC LOW)) (+ (LLSH (HILOC ADDR) 16) (LOLOC ADDR)) (+ (LLSH (HILOC HI) 16) (LOLOC HI))) (HELP)))) ) (DEFTEST (BITBLT-DIAGONALS :COMPILED) (FOR WIDTH IN '(1 2 3 4 5 7 8 9 15 16 17 31 32 33 39 40 41) ALWAYS (PRINT WIDTH) (* \; "DD") (DIAGONALS WIDTH))) (DEFTEST (BITBLT-SLOPED-LINES :COMPILED) (FOR I IN '(1 3 4 5 7 8 9 15 16 17) DO (SLOPED-LINES I)) T) (* \; "COPY.N") (CL:DEFUN XCL-USER::COPY.N.TEST (XCL-USER::USE-UFN) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 2 1 :OK -1 -2) (CL:FUNCALL (\\GETUFNENTRY 'COPY.N) 4)) ((OPCODES COPY.N 4) 2 1 :OK -1 -2))) (DEFTEST (COPY.N :COMPILED) (* |;;| "COPY.N opcode") (EQ :OK (XCL-USER::COPY.N.TEST))) (DEFTEST COPY.N-UFN (EQ :OK (XCL-USER::COPY.N.TEST T))) (* \; "STORE.N") (CL:DEFUN XCL-USER::STORE.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (STORE.N.TEST NIL) and (STORE.N.TEST T) should return the list (5 4 t 2 1)" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 5 4 3 2 1) (CL:FUNCALL (\\GETUFNENTRY 'STORE.N) T 4)) ((OPCODES STORE.N 4) 5 4 3 2 1 T)) ((OPCODES APPLYFN) 5 'LIST)) (DEFTEST (STORE.N :COMPILED) (* |;;| "COPY.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST))) (DEFTEST STORE.N-UFN (* |;;| "STORE.N opcode") (EQUAL '(5 4 T 2 1) (XCL-USER::STORE.N.TEST T))) (* \; "POP.N") (CL:DEFUN XCL-USER::POP.N.TEST (XCL-USER::USE-UFN) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (CL:IF XCL-USER::USE-UFN (PROGN ((OPCODES COPY) 4 3 2 1 0) (CL:FUNCALL (\\GETUFNENTRY 'POP.N) 2)) ((OPCODES POP.N 2) 4 3 2 1 0))) (DEFTEST (POP.N :COMPILED) (= 3 (XCL-USER::POP.N.TEST))) (DEFTEST POP.N-UFN (= 3 (XCL-USER::POP.N.TEST T))) (* \; "UNWIND") (DEFTEST UNWIND-OFF-BY-1-A (LET ((F CL:PI)) (EQUAL (LIST 'SUCCESS (PROGN (|for| C |in| (UNPACK F) |do| (PRIN1 C)) F)) '(SUCCESS 3.1415927)))) (DEFTEST UNWIND-OFF-BY-1-B (* |;;| "Make sure that UNWIND doesn't mung the binding for F during the for loop.") (LET ((F CL:PI)) (|for| C |in| (UNPACK F) |do| (PRIN1 C)) (AND (FLOATP F) (= F CL:PI)))) (DEFINEQ (UNWINDTESTER (LAMBDA (DEPTH) (* \; "Edited 16-Nov-88 18:00 by jds") (|for| D |from| 0 |to| (OR DEPTH 10) |do| (LET ((VALUE (UNWINDMAINTEST D (LOGAND D 7)))) (COND ((NEQ VALUE 'SUCCESS) (HELP "UNWINDMAINTEST did not return correctly" VALUE))))) - T)) - -(UNWINDMAINTEST + T)) (UNWINDMAINTEST (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (COND ((OR (NULL DEPTH) @@ -539,19 +50,13 @@ (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") (UNWINDMAINTEST.RECURSE (SUB1 DEPTH) - CODE))))) - -(UNWINDMAINTEST.RECURSE + CODE))))) (UNWINDMAINTEST.RECURSE (LAMBDA (DEPTH CODE) (* \; "Edited 26-Sep-88 14:08 by bvm") - (UNWINDMAINTEST DEPTH CODE))) - -(UNWINDCHECK1 + (UNWINDMAINTEST DEPTH CODE))) (UNWINDCHECK1 (LAMBDA NIL (* |bvm:| "21-Jul-86 13:15") (* \;  "This just prevents compiler from merging specials") - NIL)) - -(UNWINDCHECK2 + NIL)) (UNWINDCHECK2 (LAMBDA (CODE) (* \; "Edited 26-Sep-88 14:10 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing. TOS should be PREVIOUS-VALUE if the UNWIND said to preserve TOS.") @@ -600,34 +105,11 @@ (PROGN (* |;;| "Escape from UNWINDMAINTEST because the UNWIND there has ruined its stack") - (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) - -(UNWINDCODE + (RETFROM 'UNWINDMAINTEST 'SUCCESS))))) (UNWINDCODE (LAMBDA (CODE) (* |bvm:| "21-Jul-86 15:34") (CONCAT "UNWIND." (PLUS 10 (LOGAND CODE 1)) "." - (LRSH CODE 1)))) -) -(DECLARE\: EVAL@COMPILE DONTCOPY -(DECLARE\: EVAL@COMPILE - -(BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) - (NIL BITS 15)) - (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) - (BINDLASTPVAR WORD))) - (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN - (* |Value| |stored| |in| |high| - |half| |is| |one's| |complement| - |of| |number| |of| |values| |bound|) - (LOGXOR (|fetch| - BINDNEGVALUES - |of| DATUM) - 65535)))))) -) -) -(DEFINEQ - -(UW2.TEST + (LRSH CODE 1)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* |Value| |stored| |in| |high|  |half| |is| |one's| |complement|  |of| |number| |of| |values| |bound|) (LOGXOR (|fetch| BINDNEGVALUES |of| DATUM) 65535)))))) ) ) (DEFINEQ (UW2.TEST (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:00 by vanmelle") (COND ((OR (NULL DEPTH) @@ -635,14 +117,10 @@ (UW2.TEST.MAIN)) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") - (UW2.RECURSE (SUB1 DEPTH)))))) - -(UW2.RECURSE + (UW2.RECURSE (SUB1 DEPTH)))))) (UW2.RECURSE (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 14:56 by vanmelle") (* \; "To foil compiler") - (UW2.TEST DEPTH))) - -(UW2.TEST.MAIN + (UW2.TEST DEPTH))) (UW2.TEST.MAIN (LAMBDA (DEPTH) (* \; "Edited 20-Oct-88 15:49 by bvm") (LET ((*B* 3) (*C* 2.4) @@ -655,9 +133,7 @@ (* |;;| "There are 4 pvar slots in this frame, so empty stack = 4+2 = 6. Right now the stack depth is up to 9, because of 2 bind marks and the value from NILL.") (UNWINDCHECKFAIL T NIL ((OPCODES UNWIND 9 0)) - (UW2.CHECK))))))) - -(UW2.CHECK + (UW2.CHECK))))))) (UW2.CHECK (LAMBDA NIL (* \; "Edited 20-Oct-88 15:49 by bvm") (* |;;;| "Check that the UNWIND opcode executed prior to this did the right thing.") @@ -687,35 +163,16 @@ (PROGN (* |;;| "Escape from test because the UNWIND there has confused its stack") - (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) - -(UW2.IDENTITY + (RETFROM 'UW2.TEST.MAIN 'SUCCESS))))) (UW2.IDENTITY (LAMBDA (X) (* \; "Edited 20-Oct-88 15:19 by bvm") (* \;  "Identity compiler doesn't know about") - X)) -) - -(DEFTEST (UNWIND :COMPILED) - (UNWINDTESTER)) - -(DEFTEST (UNWIND-2 :COMPILED) - (FOR I FROM 0 TO 100 ALWAYS (EQ 'SUCCESS (UW2.TEST I)))) - - - -(* \; "FINDKEY") - -(DEFINEQ - -(FINDKEYTESTER + X)) ) (DEFTEST (UNWIND :COMPILED) (UNWINDTESTER)) (DEFTEST (UNWIND-2 :COMPILED) (FOR I FROM 0 TO 100 ALWAYS (EQ 'SUCCESS (UW2.TEST I)))) (* \; "FINDKEY") (DEFINEQ (FINDKEYTESTER (LAMBDA NIL (* |bvm:| "14-Jul-86 17:54") (* |;;;| "Test the opcode FINDKEY") - (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) - -(DOFINDKEYTEST + (DOFINDKEYTEST '|| 'VALA 'KEYB 'VALB 'KEYC 'VALC))) (DOFINDKEYTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:37") (DECLARE (SPECVARS KEYARGS)) (AND (FINDKEYCHECK 1 ||) @@ -741,9 +198,7 @@ (FINDKEYCHECK 5 KEYC) (FINDKEYCHECK 6 KEYC) (FINDKEYCHECK 7 KEYC) - (FINDKEYCHECK 8 KEYC)))) - -(DOFINDKEYTEST1 + (FINDKEYCHECK 8 KEYC)))) (DOFINDKEYTEST1 (LAMBDA (RESULT N KEY) (* |bvm:| "21-Jul-86 16:37") (DECLARE (USEDFREE KEYARGS)) (LET ((ANSWER (|for| I |from| N |by| 2 |to| KEYARGS @@ -752,29 +207,7 @@ ((NEQ ANSWER RESULT) (HELP (CONCAT "FINDKEY." N " returned " RESULT " instead of " ANSWER " for ") KEY)) - (T T))))) -) -(DECLARE\: EVAL@COMPILE DONTCOPY -(DECLARE\: EVAL@COMPILE - -(PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) `(DOFINDKEYTEST1 ((OPCODES FINDKEY - ,N) - ',KEY) - ,N - ',KEY))) -) -) - -(DEFTEST (FINDKEY :COMPILED) - (FINDKEYTESTER)) - - - -(* \; "RESTLIST") - -(DEFINEQ - -(\\RESTLIST.SPLICE.FRAME + (T T))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS FINDKEYCHECK DMACRO (DEFMACRO (N KEY) `(DOFINDKEYTEST1 ((OPCODES FINDKEY ,N) ',KEY) ,N ',KEY))) ) ) (DEFTEST (FINDKEY :COMPILED) (FINDKEYTESTER)) (* \; "RESTLIST") (DEFINEQ (\\RESTLIST.SPLICE.FRAME (LAMBDA NIL (* |bvm:| "21-Jul-86 17:13") (* |;;;| "If caller is fast, so its BF is contiguous with its caller's FX, then adjust pointers so that its first ivar goes back on it's caller's fx, and back up pc") @@ -794,9 +227,7 @@ (|replace| (FX NEXTBLOCK) |of| CALLER2 |with| IVAR) (|add| (|fetch| (FX PC) |of| CALLER2) -2) - T)))))) - -(RESTLISTTESTER + T)))))) (RESTLISTTESTER (LAMBDA NIL (* |bvm:| "21-Jul-86 17:28") (* |;;;| "Test the opcode RESTLIST") @@ -810,9 +241,7 @@ '(VALC)) (DORESTLISTTEST) (\\COMPUTED.FORM (CONS 'DORESTLISTTEST (|for| I |from| 1 |to| 200 - |collect| `',(LIST I))))))) - -(DORESTLISTTEST + |collect| `',(LIST I))))))) (DORESTLISTTEST (LAMBDA KEYARGS (* |bvm:| "21-Jul-86 16:39") (DECLARE (SPECVARS KEYARGS)) (AND (RESTLISTCHECK 1) @@ -822,14 +251,10 @@ (RESTLISTCHECK 5) (RESTLISTCHECK 6) (RESTLISTCHECK 7) - (RESTLISTCHECK 8)))) - -(GETRESTARGREFCNTS + (RESTLISTCHECK 8)))) (GETRESTARGREFCNTS (LAMBDA (N) (DECLARE (USEDFREE KEYARGS)) (* |bvm:| "18-Jul-86 15:01") - (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) - -(DORESTLISTTEST1 + (|for| I |from| N |to| KEYARGS |collect| (\\REFCNT (ARG KEYARGS I))))) (DORESTLISTTEST1 (LAMBDA (REFCNTS RESULT N) (* |bvm:| "21-Jul-86 17:22") (DECLARE (USEDFREE KEYARGS)) (COND @@ -860,50 +285,10 @@ "Ref cnt of RESTLIST value is not zero") (T "Ref cnt of RESTLIST tail is not one")) (\\REFCNT TAIL))))) - T)) -) - -(RPAQ? RESTLISTCOUNTER 0) -(DECLARE\: EVAL@COMPILE DONTCOPY -(DECLARE\: EVAL@COMPILE - -(PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) `(PROGN (RECLAIM) - (DORESTLISTTEST1 - (GETRESTARGREFCNTS ,N) - ((OPCODES RESTLIST ,N) - NIL KEYARGS) - ,N)))) - -(PUTPROPS \\COMPUTED.FORM MACRO (X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL))))) -) - -(DECLARE\: EVAL@COMPILE - -(BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) - (NIL BITS 15))) -) - -(DECLARE\: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS RESTLISTCOUNTER) -) -) - -(DEFTEST (RESTLIST :COMPILED) - (RESTLISTTESTER)) - - - -(* \; "Closure tests") - -(DEFINEQ - -(CLOSURETESTER + T)) ) (RPAQ? RESTLISTCOUNTER 0) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS RESTLISTCHECK DMACRO (DEFMACRO (N) `(PROGN (RECLAIM) (DORESTLISTTEST1 (GETRESTARGREFCNTS ,N) ((OPCODES RESTLIST ,N) NIL KEYARGS) ,N)))) (PUTPROPS \\COMPUTED.FORM MACRO (X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL))))) ) (DECLARE\: EVAL@COMPILE (BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RESTLISTCOUNTER) ) ) (DEFTEST (RESTLIST :COMPILED) (RESTLISTTESTER)) (* \; "Closure tests") (DEFINEQ (CLOSURETESTER (LAMBDA (DEPTH) (* |bvm:| "21-Jul-86 16:40") (|for| D |from| 0 |to| (OR DEPTH CLOSURETEST.DEPTH) |always| (CLOSUREMAINTEST - D)))) - -(CLOSUREMAINTEST + D)))) (CLOSUREMAINTEST (LAMBDA (DEPTH) (* \; "Edited 16-Nov-88 18:01 by jds") (COND ((OR (NULL DEPTH) @@ -934,13 +319,9 @@ (T T)))) (T (* \;  "Separate call so the compiler doesn't optimize out the recursion") - (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) - -(CLOSUREMAINTEST.RECURSE + (CLOSUREMAINTEST.RECURSE (SUB1 DEPTH)))))) (CLOSUREMAINTEST.RECURSE (LAMBDA (DEPTH) (* |bvm:| "18-Jul-86 14:07") - (CLOSUREMAINTEST DEPTH))) - -(CLOSUREFNCHECK + (CLOSUREMAINTEST DEPTH))) (CLOSUREFNCHECK (LAMBDA (CLOSUREP FUNCALLP) (* |bvm:| "18-Jul-86 14:48") (LET* ((CALLER (\\MYALINK)) (PVAR0 (STACKADDBASE (|fetch| (FX FIRSTPVAR) |of| CALLER)))) @@ -953,15 +334,11 @@ (T "Call to symbol with Closure definition")) " did not store closure environment in pvar0")))) ((|fetch| (PVARSLOT BOUND) |of| PVAR0) - (HELP "FUNCALL of a null closure stored something into pvar0")))))) - -(CLOSUREFNCHECK2 + (HELP "FUNCALL of a null closure stored something into pvar0")))))) (CLOSUREFNCHECK2 (LAMBDA NIL (* |bvm:| "18-Jul-86 14:51") (* \;  "Nothing really to check for now") - NIL)) - -(CLOSUREFN1 + NIL)) (CLOSUREFN1 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") (* \;  "Vanilla closure called via FUNCALL") @@ -970,13 +347,9 @@ (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) - (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) - -(CLOSUREFN1VALUE + (CLOSUREFN1VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN1VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:30") - (LIST ARG1 ARG2 ARG3 ARG4))) - -(CLOSUREFN2 + (LIST ARG1 ARG2 ARG3 ARG4))) (CLOSUREFN2 (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") (* \;  "Vanilla closure called via FUNCALL") @@ -985,13 +358,9 @@ (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) - (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) - -(CLOSUREFN2VALUE + (CLOSUREFN2VALUE ARG1 ARG2 ARG3 ARG4)))) (CLOSUREFN2VALUE (LAMBDA (ARG1 ARG2 ARG3 ARG4) (* |bvm:| "18-Jul-86 15:37") - (LIST ARG4 ARG3 ARG2 ARG1))) - -(CLOSUREFN4CODE + (LIST ARG4 ARG3 ARG2 ARG1))) (CLOSUREFN4CODE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:53") (* \; "closure called via FNx") (CLOSUREFNCHECK T NIL) @@ -999,836 +368,14 @@ (DUMMY2 NIL)) (DECLARE (SPECVARS DUMMY1 DUMMY2)) (CLOSUREFNCHECK2) - (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) - -(CLOSUREFN4VALUE + (CLOSUREFN4VALUE ARG1 ARG2 ARG3)))) (CLOSUREFN4VALUE (LAMBDA (ARG1 ARG2 ARG3) (* |bvm:| "18-Jul-86 15:38") - (LIST ARG2 ARG3 ARG1))) -) - -(RPAQ? CLOSURETEST.DEPTH 50) - -(RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") -(DECLARE\: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) -) - -(DEFTEST (CLOSURES :COMPILED) - (CLOSURETESTER)) - - - -(* \; "Free-variable lookup") - -(DEFINEQ - -(FVARTEST0 + (LIST ARG2 ARG3 ARG1))) ) (RPAQ? CLOSURETEST.DEPTH 50) (RPAQ? CLOSURETEST.ENVIRONMENT "Closure Environment") (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLOSURETEST.DEPTH CLOSURETEST.ENVIRONMENT) ) (DEFTEST (CLOSURES :COMPILED) (CLOSURETESTER)) (* \; "Free-variable lookup") (DEFINEQ (FVARTEST0 (LAMBDA NIL (* \; "Edited 2-Aug-88 23:04 by FS") (SETTOPVAL (QUOTE TOPLEVEL1) 1) (SETTOPVAL (QUOTE TOPLEVEL2) 2) (SETTOPVAL (QUOTE NITERS) 3) (EQ (ITIMES NITERS 334) (FVARTEST1 100 200 4))) -) - -(FVARTEST1 +) (FVARTEST1 (LAMBDA (IVAR1 IVAR2 DEPTH) (* \; "Edited 2-Aug-88 23:02 by FS") (* |;;| "Recurse DEPTH times and then call FVARTEST2 to test free variable lookup.") (LET (PVAR1) (* |;;| "This block is here so that name table scanning will find it, but must skip it. PRINT so the compiler won't throw the block away.") (SETQ PVAR1 DEPTH) (PRINTOUT T "AT DEPTH " PVAR1 T)) (LET (PVAR1 PVAR2) (SETQ PVAR1 10) (SETQ PVAR2 20) (COND ((<= DEPTH 0) (FVARTEST2 4)) (T (FVARTEST1 IVAR1 IVAR2 (SUB1 DEPTH)))))) -) - -(FVARTEST2 +) (FVARTEST2 (LAMBDA (DEPTH) (* \; "Edited 2-Aug-88 22:56 by FS") (* |;;| "Recurse DEPTH times and then freely reference IVars, PVars, Globals.") (* |;;| "") (* |;;| "It needs to search past its own frames (the vars are unbound), and past FVARTEST1's frames for the globals.") (* |;;| "") (* |;;| "It will find IVARx, PVARx in FVARTEST1's frames.") (* |;;| "") (* |;;| " Loop based on the freely referenced NITERS, to test FVAR caching.") (PROG (NAMETBLE1 NAMETBLE2 TOTAL) (COND ((<= DEPTH 0) (SETQ TOTAL 0) (|for| I |from| 1 |to| NITERS |do| (SETQ TOTAL (+ TOTAL IVAR1 IVAR2 PVAR1 PVAR2 TOPLEVEL1 TOPLEVEL2 (FVARTEST3)))) (RETURN TOTAL)) (T (RETURN (FVARTEST2 (SUB1 DEPTH))))))) -) - -(FVARTEST3 +) (FVARTEST3 (LAMBDA NIL (* \; "Edited 2-Aug-88 22:54 by FS") (* |;;| "Should find TOPLEVEL1 in FVARTEST2's frame (no way to test if this is really happening, but it should test a branch of the C code.") TOPLEVEL1) -) -) - -(DEFTEST FREE-VAR-LOOKUP - (FVARTEST0)) - - - -(* \; "AREF opcode tests") - - -(RPAQQ *NON-CONSTANT-FLOAT-1* 1.0) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" - (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) - :INITIAL-CONTENTS - '(0 1 0 1))) - (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) - :DISPLACED-TO XCL-USER::ARRAY-1))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" - (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) - :INITIAL-CONTENTS - '(0 34 56 255 23))) - (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) - :DISPLACED-TO XCL-USER::ARRAY-1))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" - (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) - :INITIAL-CONTENTS - '(0 34 255 65535 23))) - (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) - :DISPLACED-TO XCL-USER::ARRAY-1))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" - (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 16) - :INITIAL-CONTENTS - '(0 -34 255 -32768 23)))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) - (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" - (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 32) - :INITIAL-CONTENTS - '(0 -34 258 -65538 2147483647)))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) - (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" - (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS - '(0.0 -34.0 3.456756E+35 -5.768E-34 5.4524)))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) - (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" - (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS - '(#\Space #\a #\b))) - (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :FATP T :INITIAL-CONTENTS - '(#\Space #\Greek-0 #\Greek-32)))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" - (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) - (+ *NON-CONSTANT-FLOAT-1* 3.4) - 'XCL-USER::C - (CONS 'XCL-USER::D 'XCL-USER::E))) - (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) - (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) - (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" - (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) - (+ *NON-CONSTANT-FLOAT-1* 3.4) - 'XCL-USER::C - (CONS 'XCL-USER::D 'XCL-USER::E))) - - (* |;;| "The IL:*NON-CONSTANT-FLOAT-1* is there to prevent using a constant float and getting screwed by refcount.") - - (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'XPOINTER :INITIAL-CONTENTS XCL-USER::LST))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) - (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) - (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" - (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :DISPLACED-TO - (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS - '(#\a #\b #\c #\d)))) - (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS - '(0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B)))) - (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) - :READ-ONLY-P T :INITIAL-CONTENTS '(0 1 2 3)))) - - (* |;;| "aref1 should punt on all these cases") - - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) - (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) - - - -(* |;;| "array-read and array-write ") - - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT - "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" - (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 0 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) - (\\PUTBASEBYTE XCL-USER::BASE 0 160) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE - "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" - (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 3 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 23 255 4) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD - "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" - (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 4 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 23 255 65535) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD - "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" - (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 20 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 -23 255 -32768) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP - "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" - (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 22 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 -23 65536 -2147483648) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) - (CAR XCL-USER::X))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP - "Opcode ARRAYREAD (MISC3 9), type single-float" - (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 54 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) - (CAR XCL-USER::X))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR - "Opcode ARRAYREAD (MISC3 9), type string-char" - (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 67 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(#\a #\b #\c #\A) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR - "Opcode ARRAYREAD (MISC3 9), type fat-string-char" - (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 68 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(#\a #\b #\c #\A) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" - (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 38 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) - (CAR XCL-USER::X))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER - "Opcode ARRAYREAD (MISC3 9), type il:xpointer" - (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC3 9) - XCL-USER::BASE 86 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) - (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) - (CAR XCL-USER::X))) - (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE - XCL-USER::I))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT - "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" - (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) - (\\PUTBASEBYTE XCL-USER::BASE 0 160) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(1 0 1 0) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) - (LIST (LDB (BYTE 1 7) - BYTE) - (LDB (BYTE 1 6) - BYTE) - (LDB (BYTE 1 5) - BYTE) - (LDB (BYTE 1 4) - BYTE)))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE - "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" - (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 23 255 4) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (\\GETBASEBYTE - XCL-USER::BASE - XCL-USER::I))))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD - "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" - (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 23 255 65535) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (\\GETBASE XCL-USER::BASE - XCL-USER::I))))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD - "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" - (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 -23 255 -32768) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR - XCL-USER::X - ) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (LET ((XCL-USER::WORD - (\\GETBASE - XCL-USER::BASE - XCL-USER::I))) - (CL:IF - (> XCL-USER::WORD - 32767) - (\\VAG2 15 - XCL-USER::WORD - ) - XCL-USER::WORD))))) - ))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP - "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" - (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0 -23 65536 -2147483648) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (\\GETBASEFIXP - XCL-USER::BASE - (CL:ASH XCL-USER::I 1 - )))))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP - "Opcode ARRAYWRITE (MISC4 7), type single-float" - (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (\\GETBASEFLOATP - XCL-USER::BASE - (CL:ASH XCL-USER::I 1)))))) - )))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR - "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" - (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(#\a #\b #\c #\A) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR - XCL-USER::X - ) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE - - XCL-USER::BASE - XCL-USER::I)) - )))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR - "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" - (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X '(#\a #\b #\c #\A) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X - ) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE - - XCL-USER::BASE - XCL-USER::I)) - )))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER - "Opcode ARRAYWRITE (MISC4 7), type t" - (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A - 'XCL-USER::B) - ) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION - (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE - (CL:ASH XCL-USER::I 1)) - (\\REFCNT (\\GETBASEPTR XCL-USER::BASE - (CL:ASH XCL-USER::I 1)))) - )))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER - "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" - (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) - ((OPCODES MISC4 7) - XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) - (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) - (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) - (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A - 'XCL-USER::B) - ) - (CDR XCL-USER::X))) - ((EQ XCL-USER::I 4)) - (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X - ) - XCL-USER::BASE XCL-USER::I))) - (XCL:COLLECT (XCL:WITH-COLLECTION - (CL:DOTIMES (XCL-USER::I 4) - (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE - (CL:ASH XCL-USER::I 1)) - (\\REFCNT (\\GETBASEPTR XCL-USER::BASE - (CL:ASH XCL-USER::I 1)))) - )))))))) - - - -(* |;;| "Boxed opcodes") - - -(RPAQQ *NON-CONSTANT-T* T) - -(RPAQQ *NON-CONSTANT-0* 0) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1 -3 9834756987354 21845 -54)) - (CL:DOLIST (XCL-USER::Y '(1 -3 9834756987354 21845 -54)) - (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 -54.0)) - (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 -3 1/3 9834756987354 21845 -54)) - (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) - -(DEFTESTGROUP ERROR+ - (DO-TEST T-FIRST (EXPECT-ERRORS (T) - (+ *NON-CONSTANT-T* 3))) - (DO-TEST T-SECOND (EXPECT-ERRORS (T) - (+ 3 *NON-CONSTANT-T*)))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- - "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" - (LET ((XCL-USER::X 3)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 9834756987354 21845 -54)) - (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- - "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845.0 -54.0)) - (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- - "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 1/3 9834756987354 21845 -54)) - (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* - "Opcodes ITIMES,FTIMES, and TIMES, both args integer" - (LET ((XCL-USER::X 3)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 345235424 0 23 21845)) - (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* - "Opcodes ITIMES,FTIMES, and TIMES, both args float" - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) - (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 1/3 345235424 0 23 21845)) - (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ - "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" - (LET ((XCL-USER::X 21845)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 345235424 -45)) - (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ - "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38)) - (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ - "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 4/3 -1345619432 45)) - (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) - -(DEFTESTGROUP ERROR/T - (DO-TEST T-DIVISOR (EXPECT-ERRORS (T) - (/ 34 *NON-CONSTANT-T*))) - (DO-TEST T-NUMERATOR (EXPECT-ERRORS (T) - (/ *NON-CONSTANT-T* 34)))) - -(DEFTEST ERROR/0 - (EXPECT-ERRORS (T) - (/ 34 *NON-CONSTANT-0*))) - -(DEFTEST NO-ERROR-0/0 - (/ *NON-CONSTANT-0* *NON-CONSTANT-0*)) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> - "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" - (LET ((XCL-USER::X 21845)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 -45 345235424 22000)) - (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> - "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 22000.0)) - (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> - "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1/3 -45 5498457654 22000)) - (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) - (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) - - - -(* |;;| "Unboxed opcodes [scalar]") - - - - -(* |;;| "Ubfloat1") - - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '((16256 . 0) - (0 . 0) - (49716 . 0) - (26309 . 45156))) - (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) - (CDR XCL-USER::X))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 0.0 -45.0 4.6678E+23)) - (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) - (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) - (\\LOLOC XCL-USER::Y))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" - (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) - (\\FLOATBOX ((OPCODES UBFLOAT1 2) - (\\FLOATUNBOX XCL-USER::X))))) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) - (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" - (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) - (\\FLOATBOX ((OPCODES UBFLOAT1 3) - (\\FLOATUNBOX XCL-USER::X))))) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) - (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" - (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) - ((OPCODES UBFLOAT1 4) - (\\FLOATUNBOX XCL-USER::X)))) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) - (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) - - - -(* |;;| "Ubfloat2") - - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" - (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) - (\\FLOATBOX ((OPCODES UBFLOAT2 0) - (\\FLOATUNBOX XCL-USER::X) - (\\FLOATUNBOX XCL-USER::Y))))) - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 3)) - (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" - (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) - (\\FLOATBOX ( - (* |;;| "ub -") - - (OPCODES UBFLOAT2 1) - (\\FLOATUNBOX XCL-USER::X) - (\\FLOATUNBOX XCL-USER::Y))))) - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845 1/3 -54.0)) - (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" - (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) - (\\FLOATBOX ((OPCODES UBFLOAT2 3) - (\\FLOATUNBOX XCL-USER::X) - (\\FLOATUNBOX XCL-USER::Y))))) - (LET ((XCL-USER::X 3.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) - (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" - (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) - (\\FLOATBOX ((OPCODES UBFLOAT2 4) - (\\FLOATUNBOX XCL-USER::X) - (\\FLOATUNBOX XCL-USER::Y))))) - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(0.001 1.0 -3.4523542E+8 45.0 - 3.4028235E+38)) - (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" - (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) - ((OPCODES UBFLOAT2 5) - (\\FLOATUNBOX XCL-USER::X) - (\\FLOATUNBOX XCL-USER::Y)))) - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) - (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" - (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) - (\\FLOATBOX ((OPCODES UBFLOAT2 6) - (\\FLOATUNBOX XCL-USER::X) - (\\FLOATUNBOX XCL-USER::Y))))) - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) - (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" - (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) - (\\FLOATBOX ((OPCODES UBFLOAT2 7) - (\\FLOATUNBOX XCL-USER::X) - (\\FLOATUNBOX XCL-USER::Y))))) - (LET ((XCL-USER::X 21845.0)) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) - (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) - - - -(* |;;| "Ubfloat3") - - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" - (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) - (\\FLOATBOX ((OPCODES UBFLOAT3 0) - (\\FLOATUNBOX XCL-USER::X) - XCL-USER::BASE XCL-USER::SIZE)))) - (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS - '(1.0 2.0 3.0 4.0))) - (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR '((1.0 . 3) - (1.0 . 1) - (3.5 . 3))) - (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) - XCL-USER::BASE - (CDR XCL-USER::PAIR)))))))) - - - -(* |;;| "Transcendentals --- stress test") - - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) - (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) - (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 20.5 1/3 -5.2)) - (XCL:COLLECT (CL:EXP XCL-USER::X))))) - -(XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" - (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(2.7182817 -2.0 453.78)) - (XCL:COLLECT (CL:LOG XCL-USER::X))))) -(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) -) -(PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (20412 20637 (ADDR-IN-RANGE 20422 . 20635)) (23316 30084 (UNWINDTESTER 23326 . 23732) ( -UNWINDMAINTEST 23734 . 26742) (UNWINDMAINTEST.RECURSE 26744 . 26913) (UNWINDCHECK1 26915 . 27213) ( -UNWINDCHECK2 27215 . 29880) (UNWINDCODE 29882 . 30082)) (31160 34419 (UW2.TEST 31170 . 31601) ( -UW2.RECURSE 31603 . 31842) (UW2.TEST.MAIN 31844 . 32501) (UW2.CHECK 32503 . 34111) (UW2.IDENTITY 34113 - . 34417)) (34608 36213 (FINDKEYTESTER 34618 . 34832) (DOFINDKEYTEST 34834 . 35714) (DOFINDKEYTEST1 -35716 . 36211)) (36767 41156 (\\RESTLIST.SPLICE.FRAME 36777 . 38111) (RESTLISTTESTER 38113 . 38687) ( -DORESTLISTTEST 38689 . 39058) (GETRESTARGREFCNTS 39060 . 39281) (DORESTLISTTEST1 39283 . 41154)) ( -42086 47428 (CLOSURETESTER 42096 . 42398) (CLOSUREMAINTEST 42400 . 44327) (CLOSUREMAINTEST.RECURSE -44329 . 44485) (CLOSUREFNCHECK 44487 . 45290) (CLOSUREFNCHECK2 45292 . 45586) (CLOSUREFN1 45588 . -46077) (CLOSUREFN1VALUE 46079 . 46226) (CLOSUREFN2 46228 . 46717) (CLOSUREFN2VALUE 46719 . 46866) ( -CLOSUREFN4CODE 46868 . 47282) (CLOSUREFN4VALUE 47284 . 47426)) (47708 49342 (FVARTEST0 47718 . 47925) -(FVARTEST1 47927 . 48431) (FVARTEST2 48433 . 49119) (FVARTEST3 49121 . 49340))))) -STOP +) ) (DEFTEST FREE-VAR-LOOKUP (FVARTEST0)) (* \; "AREF opcode tests") (RPAQQ *NON-CONSTANT-FLOAT-1* 1.0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BIT "Opcode aref1, type (unsigned-byte 1)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) :INITIAL-CONTENTS '(0 1 0 1))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 1) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-BYTE "Opcode aref1, type (unsigned-byte 8)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :INITIAL-CONTENTS '(0 34 56 255 23))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-WORD "Opcode aref1, type (unsigned-byte 16)" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) :INITIAL-CONTENTS '(0 34 255 65535 23))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 16) :DISPLACED-TO XCL-USER::ARRAY-1))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-SIGNED-WORD "Opcode aref1, type (signed-byte 16)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 16) :INITIAL-CONTENTS '(0 -34 255 -32768 23)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FIXP "Opcode aref1, type (signed-byte 32)" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE '(CL:SIGNED-BYTE 32) :INITIAL-CONTENTS '(0 -34 258 -65538 2147483647)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-FLOATP "Opcode aref1, type single-float" (LET ((CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS '(0.0 -34.0 3.456756E+35 -5.768E-34 5.4524)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CL:AREF CL:ARRAY XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-STRING-CHAR "Opcode aref1, type string-char" (LET ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS '(#\Space #\a #\b))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 3 :ELEMENT-TYPE 'CL:STRING-CHAR :FATP T :INITIAL-CONTENTS '(#\Space #\Greek-0 #\Greek-32)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 3) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-POINTER "Opcode aref1, type t" (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) (+ *NON-CONSTANT-FLOAT-1* 3.4) 'XCL-USER::C (CONS 'XCL-USER::D 'XCL-USER::E))) (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE T :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-XPOINTER "Opcode aref1, type il:xpointer" (LET* ((XCL-USER::LST (LIST 0 (CONS 'XCL-USER::A 'XCL-USER::B) (+ *NON-CONSTANT-FLOAT-1* 3.4) 'XCL-USER::C (CONS 'XCL-USER::D 'XCL-USER::E))) (* |;;| "The IL:*NON-CONSTANT-FLOAT-1* is there to prevent using a constant float and getting screwed by refcount.") (CL:ARRAY (CL:MAKE-ARRAY 5 :ELEMENT-TYPE 'XPOINTER :INITIAL-CONTENTS XCL-USER::LST))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 5) (XCL:COLLECT (CONS (CL:AREF CL:ARRAY XCL-USER::I) (\\REFCNT (CL:AREF CL:ARRAY XCL-USER::I)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::AREF1-PUNT "Opcode aref1, punt cases" (LET* ((XCL-USER::ARRAY-1 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :DISPLACED-TO (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:STRING-CHAR :INITIAL-CONTENTS '(#\a #\b #\c #\d)))) (XCL-USER::ARRAY-2 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE T :ADJUSTABLE T :INITIAL-CONTENTS '(0 XCL-USER::A XCL-USER::B (XCL-USER::A . XCL-USER::B)))) (XCL-USER::ARRAY-3 (CL:MAKE-ARRAY 4 :ELEMENT-TYPE '(CL:UNSIGNED-BYTE 8) :READ-ONLY-P T :INITIAL-CONTENTS '(0 1 2 3)))) (* |;;| "aref1 should punt on all these cases") (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-1 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-2 XCL-USER::I)) (XCL:COLLECT (CL:AREF XCL-USER::ARRAY-3 XCL-USER::I)))))) (* |;;| "array-read and array-write ") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BIT "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-READ-BIT (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BIT XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-BYTE "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-READ-BYTE (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 4) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-BYTE XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-WORD "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 65535) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-SIGNED-WORD "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-READ-SIGNED-WORD (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 255 -32768) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (\\LOLOC (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-SIGNED-WORD XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FIXP "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-READ-FIXP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 65536 -2147483648) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FIXP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FLOATP "Opcode ARRAYREAD (MISC3 9), type single-float" (CL:FLET ((XCL-USER::ARRAY-READ-FLOATP (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FLOATP XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-THIN-CHAR "Opcode ARRAYREAD (MISC3 9), type string-char" (CL:FLET ((XCL-USER::ARRAY-READ-THIN-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEBYTE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-THIN-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-FAT-CHAR "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-READ-FAT-CHAR (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASE XCL-USER::BASE XCL-USER::I (CL:CHAR-CODE (CAR XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-FAT-CHAR XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-POINTER "Opcode ARRAYREAD (MISC3 9), type t" (CL:FLET ((XCL-USER::ARRAY-READ-POINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\RPLPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-POINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-READ-XPOINTER "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-READ-XPOINTER (XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC3 9) XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(2 #\c 2.3 (XCL-USER::A . XCL-USER::B)) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (\\PUTBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1) (CAR XCL-USER::X))) (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (XCL-USER::ARRAY-READ-XPOINTER XCL-USER::BASE XCL-USER::I))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BIT "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BIT (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 0 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 8 0))) (\\PUTBASEBYTE XCL-USER::BASE 0 160) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(1 0 1 0) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BIT (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (LET ((BYTE (\\GETBASEBYTE XCL-USER::BASE 0))) (LIST (LDB (BYTE 1 7) BYTE) (LDB (BYTE 1 6) BYTE) (LDB (BYTE 1 5) BYTE) (LDB (BYTE 1 4) BYTE)))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-BYTE "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (CL:FLET ((XCL-USER::ARRAY-WRITE-BYTE (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 3 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 3))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 4) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-BYTE (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-WORD "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 4 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 4))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 23 255 65535) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-WORD (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASE XCL-USER::BASE XCL-USER::I))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-SIGNED-WORD "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (CL:FLET ((XCL-USER::ARRAY-WRITE-SIGNED-WORD (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 20 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 20))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 255 -32768) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-SIGNED-WORD (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (LET ((XCL-USER::WORD (\\GETBASE XCL-USER::BASE XCL-USER::I))) (CL:IF (> XCL-USER::WORD 32767) (\\VAG2 15 XCL-USER::WORD ) XCL-USER::WORD))))) ))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FIXP "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (CL:FLET ((XCL-USER::ARRAY-WRITE-FIXP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 22 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 22))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0 -23 65536 -2147483648) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FIXP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFIXP XCL-USER::BASE (CL:ASH XCL-USER::I 1 )))))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FLOATP "Opcode ARRAYWRITE (MISC4 7), type single-float" (CL:FLET ((XCL-USER::ARRAY-WRITE-FLOATP (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 54 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 54))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(0.0 -23.0 3.4456E+24 -4.562435E-12) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FLOATP (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (\\GETBASEFLOATP XCL-USER::BASE (CL:ASH XCL-USER::I 1)))))) )))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-THIN-CHAR "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-THIN-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 67 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 67))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-THIN-CHAR (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASEBYTE XCL-USER::BASE XCL-USER::I)) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-FAT-CHAR "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (CL:FLET ((XCL-USER::ARRAY-WRITE-FAT-CHAR (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 68 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 68))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X '(#\a #\b #\c #\A) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-FAT-CHAR (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CL:CODE-CHAR (\\GETBASE XCL-USER::BASE XCL-USER::I)) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-POINTER "Opcode ARRAYWRITE (MISC4 7), type t" (CL:FLET ((XCL-USER::ARRAY-WRITE-POINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 38 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 38))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A 'XCL-USER::B) ) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-POINTER (CAR XCL-USER::X) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))) )))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::ARRAY-WRITE-XPOINTER "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (CL:FLET ((XCL-USER::ARRAY-WRITE-XPOINTER (XCL-USER::NEW-VALUE XCL-USER::BASE XCL-USER::INDEX) ((OPCODES MISC4 7) XCL-USER::NEW-VALUE XCL-USER::BASE 86 XCL-USER::INDEX))) (LET ((XCL-USER::BASE (%MAKE-ARRAY-STORAGE 4 86))) (XCL:WITH-COLLECTION (CL:DO ((XCL-USER::I 0 (CL:1+ XCL-USER::I)) (XCL-USER::X (LIST 2 #\c 'XCL-USER::A (CONS 'XCL-USER::A 'XCL-USER::B) ) (CDR XCL-USER::X))) ((EQ XCL-USER::I 4)) (XCL:COLLECT (XCL-USER::ARRAY-WRITE-XPOINTER (CAR XCL-USER::X ) XCL-USER::BASE XCL-USER::I))) (XCL:COLLECT (XCL:WITH-COLLECTION (CL:DOTIMES (XCL-USER::I 4) (XCL:COLLECT (CONS (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)) (\\REFCNT (\\GETBASEPTR XCL-USER::BASE (CL:ASH XCL-USER::I 1)))) )))))))) (* |;;| "Boxed opcodes") (RPAQQ *NON-CONSTANT-T* T) (RPAQQ *NON-CONSTANT-0* 0) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT+ "Opcodes IPLUS,FPLUS, and PLUS, both args integer" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1 -3 -718120486 21845 -54)) (CL:DOLIST (XCL-USER::Y '(1 -3 -718120486 21845 -54)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT+ "Opcodes IPLUS,FPLUS, and PLUS, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 -54.0)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED+ "Opcodes IPLUS,FPLUS, and PLUS, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 -3 1/3 -718120486 21845 -54)) (XCL:COLLECT (IPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FPLUS XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (PLUS XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR+ (DO-TEST T-FIRST (EXPECT-ERRORS (T) (+ *NON-CONSTANT-T* 3))) (DO-TEST T-SECOND (EXPECT-ERRORS (T) (+ 3 *NON-CONSTANT-T*)))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 -718120486 21845 -54)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845.0 -54.0)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED- "Opcodes IDIFFERENCE,FDIFFERENCE, and DIFFERENCE, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1 3 1/3 -718120486 21845 -54)) (XCL:COLLECT (IDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FDIFFERENCE XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (DIFFERENCE XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT* "Opcodes ITIMES,FTIMES, and TIMES, both args integer" (LET ((XCL-USER::X 3)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 345235424 0 23 21845)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT* "Opcodes ITIMES,FTIMES, and TIMES, both args float" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED* "Opcodes ITIMES,FTIMES, and TIMES, mixed args" (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45 1/3 345235424 0 23 21845)) (XCL:COLLECT (ITIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FTIMES XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (TIMES XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 345235424 -45)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, both args float" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED/ "Opcodes IQUOTIENT,FQUOTIENT, and QUOTIENT, args mixed" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1 4/3 -1345619432 45)) (XCL:COLLECT (IQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FQUOTIENT XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (QUOTIENT XCL-USER::X XCL-USER::Y)))))) (DEFTESTGROUP ERROR/T (DO-TEST T-DIVISOR (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-T*))) (DO-TEST T-NUMERATOR (EXPECT-ERRORS (T) (/ *NON-CONSTANT-T* 34)))) (DEFTEST ERROR/0 (EXPECT-ERRORS (T) (/ 34 *NON-CONSTANT-0*))) (DEFTEST NO-ERROR-0/0 (/ *NON-CONSTANT-0* *NON-CONSTANT-0*)) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::INT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 -45 345235424 22000)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::FLOAT> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 22000.0)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::MIXED> "Opcodes IGREATERP,FGREATERP, and GREATERP, both args integer" (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845 1/3 -45 1203490358 22000)) (XCL:COLLECT (IGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (FGREATERP XCL-USER::X XCL-USER::Y)) (XCL:COLLECT (GREATERP XCL-USER::X XCL-USER::Y)))))) (* |;;| "Unboxed opcodes [scalar]") (* |;;| "Ubfloat1") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::BOX "Opcode BOX (UBFLOAT1 0)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '((16256 . 0) (0 . 0) (49716 . 0) (26309 . 45156))) (XCL:COLLECT (\\FLOATBOX (\\VAG2 (CAR XCL-USER::X) (CDR XCL-USER::X))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UNBOX "Opcode UNBOX (UBFLOAT1 1)" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 0.0 -45.0 4.6678E+23)) (LET ((XCL-USER::Y (\\FLOATUNBOX XCL-USER::X))) (XCL:COLLECT (CONS (\\HILOC XCL-USER::Y) (\\LOLOC XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBABS "Opcode UFABS (UBFLOAT1 2)" (CL:FLET ((XCL-USER::UBABS (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 2) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBABS XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBNEGATE "Opcode UFNEGATE (UBFLOAT1 3)" (CL:FLET ((XCL-USER::UBNEGATE (XCL-USER::X) (\\FLOATBOX ((OPCODES UBFLOAT1 3) (\\FLOATUNBOX XCL-USER::X))))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBNEGATE XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBFIX "Opcode UFIX (UBFLOAT1 4)" (CL:FLET ((XCL-USER::UBFIX (XCL-USER::X) ((OPCODES UBFLOAT1 4) (\\FLOATUNBOX XCL-USER::X)))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(-1.0 0.0 -45.0 4.6678E+23)) (XCL:COLLECT (XCL-USER::UBFIX XCL-USER::X)))))) (* |;;| "Ubfloat2") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB+ "Opcode UFADD (UBFLOAT2 0)" (CL:FLET ((XCL-USER::UB+ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 0) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 -3.0 -3.4028235E+38 21845.0 3)) (XCL:COLLECT (XCL-USER::UB+ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB- "Opcode UFSUB (UBFLOAT2 1)" (CL:FLET ((XCL-USER::UB- (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ( (* |;;| "ub -") (OPCODES UBFLOAT2 1) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(1.0 3.0 3.4028235E+38 21845 1/3 -54.0)) (XCL:COLLECT (XCL-USER::UB- XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB* "Opcode UFMULT (UBFLOAT2 3)" (CL:FLET ((XCL-USER::UB* (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 3) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 3.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(45.0 0.0 1.1342745E+38 -21845.0)) (XCL:COLLECT (XCL-USER::UB* XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB/ "Opcode UFDIV (UBFLOAT2 4)" (CL:FLET ((XCL-USER::UB/ (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 4) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(0.001 1.0 -3.4523542E+8 45.0 3.4028235E+38)) (XCL:COLLECT (XCL-USER::UB/ XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UB> "Opcode UFGREAT (UBFLOAT2 5)" (CL:FLET ((XCL-USER::UB> (XCL-USER::X XCL-USER::Y) ((OPCODES UBFLOAT2 5) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y)))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UB> XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMAX "Opcode UFMAX (UBFLOAT2 6)" (CL:FLET ((XCL-USER::UBMAX (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 6) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UBMAX XCL-USER::X XCL-USER::Y))))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::UBMIN "Opcode UFMAX (UBFLOAT2 7)" (CL:FLET ((XCL-USER::UBMIN (XCL-USER::X XCL-USER::Y) (\\FLOATBOX ((OPCODES UBFLOAT2 7) (\\FLOATUNBOX XCL-USER::X) (\\FLOATUNBOX XCL-USER::Y))))) (LET ((XCL-USER::X 21845.0)) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::Y '(21845.0 -45.0 3.4523542E+8 0.001)) (XCL:COLLECT (XCL-USER::UBMIN XCL-USER::X XCL-USER::Y))))))) (* |;;| "Ubfloat3") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::POLY "Opcode POLY (UBFLOAT3 0)" (CL:FLET ((XCL-USER::POLY (XCL-USER::X XCL-USER::BASE XCL-USER::SIZE) (\\FLOATBOX ((OPCODES UBFLOAT3 0) (\\FLOATUNBOX XCL-USER::X) XCL-USER::BASE XCL-USER::SIZE)))) (LET* ((CL:ARRAY (CL:MAKE-ARRAY 4 :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-CONTENTS '(1.0 2.0 3.0 4.0))) (XCL-USER::BASE (%ARRAY-BASE CL:ARRAY))) (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::PAIR '((1.0 . 3) (1.0 . 1) (3.5 . 3))) (XCL:COLLECT (XCL-USER::POLY (CAR XCL-USER::PAIR) XCL-USER::BASE (CDR XCL-USER::PAIR)))))))) (* |;;| "Transcendentals --- stress test") (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::SIN-TEST "Function SIN" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) (XCL:COLLECT (CL:SIN (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::COS-TEST "Function COS" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(0.0 1/3 -1.2 12.6)) (XCL:COLLECT (CL:COS (CL:* CL:PI XCL-USER::X)))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::EXP-TEST "Function EXP" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(1.0 20.5 1/3 -5.2)) (XCL:COLLECT (CL:EXP XCL-USER::X))))) (XCL-USER::DEFINE-VERIFIED-TEST XCL-USER::LOG-TEST "Function LOG" (XCL:WITH-COLLECTION (CL:DOLIST (XCL-USER::X '(2.7182817 -2.0 453.78)) (XCL:COLLECT (CL:LOG XCL-USER::X))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA DORESTLISTTEST DOFINDKEYTEST) ) (PUTPROPS OPCODES.TEST COPYRIGHT ("ENVOS Corporation" 1988 2020)) (DECLARE\: DONTCOPY (FILEMAP (NIL (6938 13254 (SIMULATE-PILOTBITBLT 6938 . 13254)) (13256 13469 (BUMP 13256 . 13469)) ( 13471 15758 (SLOPED-LINES 13471 . 15758)) (15760 20318 (DIAGONALS 15760 . 20318)) (20319 20730 ( ADDR-IN-RANGE 20329 . 20728)) (21188 21559 (XCL-USER::COPY.N.TEST 21188 . 21559)) (21755 22184 ( XCL-USER::STORE.N.TEST 21755 . 22184)) (22462 22819 (XCL-USER::POP.N.TEST 22462 . 22819)) (23441 30209 (UNWINDTESTER 23451 . 23857) (UNWINDMAINTEST 23859 . 26867) (UNWINDMAINTEST.RECURSE 26869 . 27038) ( UNWINDCHECK1 27040 . 27338) (UNWINDCHECK2 27340 . 30005) (UNWINDCODE 30007 . 30207)) (31285 34544 ( UW2.TEST 31295 . 31726) (UW2.RECURSE 31728 . 31967) (UW2.TEST.MAIN 31969 . 32626) (UW2.CHECK 32628 . 34236) (UW2.IDENTITY 34238 . 34542)) (34733 36338 (FINDKEYTESTER 34743 . 34957) (DOFINDKEYTEST 34959 . 35839) (DOFINDKEYTEST1 35841 . 36336)) (36892 41281 (\\RESTLIST.SPLICE.FRAME 36902 . 38236) ( RESTLISTTESTER 38238 . 38812) (DORESTLISTTEST 38814 . 39183) (GETRESTARGREFCNTS 39185 . 39406) ( DORESTLISTTEST1 39408 . 41279)) (42211 47553 (CLOSURETESTER 42221 . 42523) (CLOSUREMAINTEST 42525 . 44452) (CLOSUREMAINTEST.RECURSE 44454 . 44610) (CLOSUREFNCHECK 44612 . 45415) (CLOSUREFNCHECK2 45417 . 45711) (CLOSUREFN1 45713 . 46202) (CLOSUREFN1VALUE 46204 . 46351) (CLOSUREFN2 46353 . 46842) ( CLOSUREFN2VALUE 46844 . 46991) (CLOSUREFN4CODE 46993 . 47407) (CLOSUREFN4VALUE 47409 . 47551)) (47833 49467 (FVARTEST0 47843 . 48050) (FVARTEST1 48052 . 48556) (FVARTEST2 48558 . 49244) (FVARTEST3 49246 . 49465))))) STOP \ No newline at end of file diff --git a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL index c2c76bd3..f6a19b4f 100644 Binary files a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL and b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL differ diff --git a/internal/test/Maiko/OBSOLETE/unwindtest.dfasl b/internal/test/Maiko/OBSOLETE/unwindtest.dfasl index c3790291..7d2718ed 100644 Binary files a/internal/test/Maiko/OBSOLETE/unwindtest.dfasl and b/internal/test/Maiko/OBSOLETE/unwindtest.dfasl differ diff --git a/internal/test/README.TEDIT b/internal/test/README.TEDIT index 74923257..64bf72ec 100644 Binary files a/internal/test/README.TEDIT and b/internal/test/README.TEDIT differ diff --git a/internal/test/README.ps b/internal/test/README.ps new file mode 100644 index 00000000..3cd6bff4 --- /dev/null +++ b/internal/test/README.ps @@ -0,0 +1,497 @@ +%!PS-Adobe-2.0 +%%Title: {DSK}larry>ilisp>medley>internal>test>README.ps;1 +%%Creator: PostScript Driver Copyright (C) 1988-1992 Venue and others +%%CreationDate: 19-Dec-2020 18:53:07 +%%EndComments +/bdef {bind def} bind def +/ldef {load def} bdef +/S /show ldef +/M /moveto ldef +/DR {transform round exch round exch itransform} bdef +/L {gsave newpath setlinewidth 0 setlinecap + M lineto currentpoint stroke grestore M} bdef +/L1 {gsave newpath 0 setdash setgray setlinewidth 0 setlinecap + M lineto currentpoint stroke grestore M} bdef +/F {findfont exch scalefont setfont} bdef +/CLP {newpath M dup 0 rlineto exch 0 exch rlineto + neg 0 rlineto closepath clip newpath} bdef +/R {gsave setgray newpath M dup 0 rlineto exch 0 exch + rlineto neg 0 rlineto closepath eofill grestore} bdef +/ellipsedict 9 dict def +ellipsedict /mtrx matrix put +/ellipse + { ellipsedict begin + /endangle exch def + /startangle exch def + /orientation exch def + /minorrad exch def + /majorrad exch def + /y exch def + /x exch def + /savematrix mtrx currentmatrix def + x y translate + orientation rotate + majorrad minorrad scale + 0 0 1 startangle endangle arc + savematrix setmatrix + end } bdef +/concatprocs + {/proc2 exch cvlit def + /proc1 exch cvlit def + /newproc proc1 length proc2 length add array def + newproc 0 proc1 putinterval + newproc proc1 length proc2 putinterval + newproc cvx + } bdef +/resmatrix matrix def +/findresolution + {72 0 resmatrix defaultmatrix dtransform + /yres exch def /xres exch def + xres dup mul yres dup mul add sqrt + } bdef +/thebitimage + {/maskp exch def + /bihgt exch def + /biwid exch def + /byte 1 string def + /strbufl biwid 8 div ceiling cvi def + /strbuf strbufl string def + maskp not{{1 exch sub} currenttransfer concatprocs settransfer} if + biwid bihgt + maskp { true } { 1 } ifelse + [biwid 0 0 bihgt 0 0] + {/col 0 def + {currentfile byte readhexstring pop 0 get + dup 16#B2 eq {pop + currentfile byte readhexstring pop 0 get 1 add + currentfile byte readhexstring pop pop /nbyte byte 0 get def + { strbuf col nbyte put /col col 1 add def} repeat} + {dup 16#B3 eq {pop /col col + currentfile byte readhexstring pop + 0 get add 1 add def} + {16#B4 eq {currentfile byte readhexstring pop pop} if + strbuf col byte 0 get put /col col 1 add def} ifelse + } ifelse + col strbufl ge { exit } if } loop + strbuf } + maskp { imagemask } { image } ifelse + } bdef +/setuserscreendict 22 dict def +setuserscreendict begin + /tempctm matrix def + /temprot matrix def + /tempscale matrix def +end +/setuserscreen + {setuserscreendict begin + /spotfunction exch def + /screenangle exch def + /cellsize exch def + /m tempctm currentmatrix def + /rm screenangle temprot rotate def + /sm cellsize dup tempscale scale def + sm rm m m concatmatrix m concatmatrix pop + 1 0 m dtransform /y1 exch def /x1 exch def + /veclength x1 dup mul y1 dup mul add sqrt def + /frequency findresolution veclength div def + /newscreenangle y1 x1 atan def + m 2 get m 1 get mul m 0 get m 3 get mul sub + 0 gt { { neg } /spotfunction load concatprocs + /spotfunction exch def } if + frequency newscreenangle /spotfunction load setscreen + end + } bdef +/setpatterndict 18 dict def +setpatterndict begin + /bitison + {/ybit exch def /xbit exch def + /bytevalue bstring ybit bwidth mul xbit 8 idiv add get def + /mask 1 7 xbit 8 mod sub bitshift def + bytevalue mask and 0 ne + } bdef +end +/bitpatternspotfunction + {setpatterndict begin + /y exch def /x exch def + /xindex x 1 add 2 div bpside mul 1 sub cvi def + /yindex y 1 add 2 div bpside mul 1 sub cvi def + xindex yindex bitison + {/onbits onbits 1 add def 1} + {/offbits offbits 1 add def 0} ifelse + end + } bdef +/setpattern + {setpatterndict begin + /cellsz exch def + /angle exch def + /bwidth exch def + /bpside exch def + /bstring exch def + /onbits 0 def /offbits 0 def + cellsz angle /bitpatternspotfunction load setuserscreen + {} settransfer + offbits offbits onbits add div setgray + end + } bdef +% - - - - - Fraction-setting code, to support NS fonts better - - - - - +/fractiondict 20 dict def +/fractionshow +{ fractiondict begin +/denom exch def +/num exch def +/regfont currentfont def +/fractfont currentfont [.65 0 0 .6 0 0] makefont def +gsave newpath 0 0 moveto +(1) true charpath flattenpath pathbbox +/height exch def pop pop pop + grestore +0 .4 height mul rmoveto +fractfont setfont num show +0 .4 height mul neg rmoveto regfont setfont (\244) show +fractfont setfont denom show regfont setfont end } bdef +/f14 { (1) (4) fractionshow } bdef +/f12 { (1) (2) fractionshow } bdef +/f34 { (3) (4) fractionshow } bdef +/f18 { (1) (8) fractionshow } bdef +/f38 { (3) (8) fractionshow } bdef +/f58 { (5) (8) fractionshow } bdef +/f78 { (7) (8) fractionshow } bdef +/f13 { (1) (3) fractionshow } bdef +/f23 { (2) (3) fractionshow } bdef +/bboxdict 20 dict def +/bboxchk { bboxdict begin +/regfont currentfont def +/chkfont currentfont [1.25 0 0 1.25 0 0] makefont def +gsave newpath 0 0 moveto +(\161) true charpath flattenpath pathbbox +/height exch def pop pop pop + grestore + currentpoint + .2 height mul .3 height mul rmoveto +chkfont setfont (\063) show + moveto + regfont setfont +(\161) show end } bdef +/rencdict 15 dict def +/encodefont { rencdict begin +/newname exch def +/oldfont exch def +/newcodes [ +8#001 /Aacute +8#002 /Acircumflex +8#003 /Adieresis +8#004 /Agrave +8#005 /Aring +8#006 /Atilde +8#007 /Ccedilla +8#010 /Eacute +8#011 /Ecircumflex +8#012 /Edieresis +8#013 /Egrave +8#014 /Iacute +8#015 /Icircumflex +8#016 /Idieresis +8#017 /Igrave +8#020 /Ntilde +8#021 /Oacute +8#022 /Ocircumflex +8#023 /Odieresis +8#024 /Ograve +8#025 /Otilde +8#026 /Scaron +8#027 /Uacute +8#030 /Ucircumflex +8#031 /Udieresis +8#032 /Ugrave +8#033 /Ydieresis +8#034 /Zcaron +8#177 /periodinferior +8#201 /aacute +8#202 /acircumflex +8#203 /adieresis +8#204 /agrave +8#205 /aring +8#206 /atilde +8#207 /ccedilla +8#210 /eacute +8#211 /ecircumflex +8#212 /edieresis +8#213 /egrave +8#214 /iacute +8#215 /icircumflex +8#216 /idieresis +8#217 /igrave +8#220 /ntilde +8#221 /oacute +8#222 /ocircumflex +8#223 /odieresis +8#224 /ograve +8#225 /otilde +8#226 /scaron +8#227 /uacute +8#230 /ucircumflex +8#231 /udieresis +8#232 /ugrave +8#233 /ydieresis +8#234 /zcaron +8#235 /Eth +8#236 /eth +8#237 /Thorn +8#240 /thorn + ] def +/olddict oldfont findfont def /newfont olddict maxlength dict def +olddict { exch dup /FID ne { dup /Encoding eq +{ exch dup length array copy newfont 3 1 roll put } +{ exch newfont 3 1 roll put } ifelse } + { pop pop } ifelse } forall +newfont /FontName newname put +newcodes aload pop +newcodes length 2 idiv { newfont /Encoding get 3 1 roll put } repeat +newname newfont definefont pop end } def + /accentdict 10 dict def + /accentor { accentdict begin /scaler exch def /delta exch def +/unders exch def /accents exch def /mainch exch def /scrt (X) def + /w1 mainch stringwidth pop def + currentpoint mainch show currentpoint 4 2 roll +accents { /ch exch def 2 copy moveto + scrt 0 ch put + /w2 scrt stringwidth pop def + w1 w2 sub 2 div delta rmoveto scrt show + /delta delta 150 scaler mul 9 div add def + } forall +unders { /ch exch def 2 copy moveto + scrt 0 ch put + /w2 scrt stringwidth pop def + ch 46 eq { w1 w2 sub 2 div -175 scaler mul 9 div rmoveto scrt show 0 175 rmoveto } + { w1 w2 sub 2 div 0 rmoveto scrt show } ifelse + } forall + pop pop moveto end } def +%%EndProlog +%%BeginSetup +letter +/imagesizefactor 1 def +%%EndSetup +/Courier /Courier-Acnt encodefont +800 /Courier-Acnt F + +%%Page: 1 1 +%%BeginPageSetup +/savepage save def +0.01 imagesizefactor mul dup scale +%%EndPageSetup +gsave + 0 rotate + 79200 61200 0 0 CLP +/Helvetica-Bold /Helvetica-Bold-Acnt encodefont +2400 /Helvetica-Bold-Acnt F +7200 70129 M (Notes on {Medley}test>) S +1400 /Helvetica-Bold-Acnt F +7200 67108 M ( subdirs:) S +/Helvetica /Helvetica-Acnt encodefont +1400 /Helvetica-Acnt F +10800 65708 M (admin, ARs, env, GC, IO , LANGUAGE, Library, loops, lyric, Maiko,) S +7200 64308 M (tools) S +1400 /Helvetica-Bold-Acnt F +7200 62908 M () S +1400 /Helvetica-Acnt F +(Top level files) S +7200 61508 M ( ) S +1400 /Helvetica-Bold-Acnt F +10800 61508 M (README.TEDIT) S +1400 /Helvetica-Acnt F +( \(this file\)) S +1400 /Helvetica-Bold-Acnt F +10800 60108 M (TEST-RESULTS) S +1400 /Helvetica-Acnt F +( \(contains log from running AUTO tests from 1988\)) S +7200 58708 M ( ) S +1400 /Helvetica-Bold-Acnt F +10800 58708 M (DOT.read-me-first ) S +1400 /Helvetica-Acnt F +( \(originally .read-me-first\)) S +1400 /Helvetica-Bold-Acnt F +7200 54508 M (4045> ) S +1400 /Helvetica-Acnt F +( Deleted) S +1400 /Helvetica-Bold-Acnt F +7200 51708 M (Maiko>) S +1400 /Helvetica-Acnt F +7200 50308 M ( Subdir ARs, AUTO, Aux, HAND, OBSOLETE ) S +7200 48908 M ( Top level files) S +7200 46108 M ( ) S +1400 /Helvetica-Bold-Acnt F +(STACKHAX) S +1400 /Helvetica-Acnt F +( \(has CHECKSTACKSPACE, seems to get tangled up in) S +12000 44708 M (it's own stack) S +7200 43308 M ( ) S +1400 /Helvetica-Bold-Acnt F +(STACKTAKESHI) S +1400 /Helvetica-Acnt F +( \(seems to cause a stack overflow on opurpose,) S +12000 41908 M (which leaves stack clean enough that URAID hard-reset recovers) S +12000 40508 M (from. Suspect timeouts aren't correct) S +7200 39108 M ( ) S +1400 /Helvetica-Bold-Acnt F +(BAD-XREF \() S +1400 /Helvetica-Acnt F +(no compiled file\) ) S +7200 37708 M ( ) S +1400 /Helvetica-Bold-Acnt F +(display.cl) S +1400 /Helvetica-Acnt F +( \(says "from Texas Instruments"\)) S +7200 36308 M ( ) S +1400 /Helvetica-Bold-Acnt F +7200 34908 M (Maiko>ARs) S +1400 /Helvetica-Acnt F +(>) S +10800 33508 M (looks like junk: ) S +7200 32108 M ( ) S +1400 /Helvetica-Bold-Acnt F +(optests ) S +1400 /Helvetica-Acnt F +(& .dfasl \(like AUTO>OPCODES.TEST\)) S +7200 30708 M ( ) S +1400 /Helvetica-Bold-Acnt F +10800 30708 M (ENDLESSPUSHES) S +1400 /Helvetica-Acnt F +7200 29308 M ( ) S +1400 /Helvetica-Bold-Acnt F +10800 29308 M (AR-TEST-CASES.Auto-log) S +1400 /Helvetica-Bold-Acnt F +7200 25108 M (Maiko>AUTO>) S +1400 /Helvetica-Acnt F +7200 23708 M ( ) S +1400 /Helvetica-Bold-Acnt F +(OPCODES.TEST) S +1400 /Helvetica-Acnt F +7200 22308 M ( ) S +1400 /Helvetica-Bold-Acnt F +(OPCODES.DFASL) S +1400 /Helvetica-Acnt F +( ) S +10800 20908 M (may need EXPORTS.ALL to compile) S +7200 19508 M ( ) S +10800 19508 M (most tests succeed) S +7200 18108 M ( test BITBLT-DIAGONALS and BITBLT-SLOPED-LINES fail) S +7200 16708 M ( A little hard to debug because the inspector for 2D arrays fail) S +1400 /Helvetica-Bold-Acnt F +7200 13908 M (Maiko>Aux>) S +1400 /Helvetica-Acnt F +7200 12508 M ( ) S +10800 12508 M (Another cop y of ) S +1400 /Helvetica-Bold-Acnt F +(bbtests ) S +1400 /Helvetica-Acnt F +(and ) S +1400 /Helvetica-Bold-Acnt F +(optests.lisp) S +1400 /Helvetica-Bold-Acnt F +7200 9708 M (Maiko>HAND>) S +1400 /Helvetica-Acnt F +7200 8308 M ( ) S +1400 /Helvetica-Bold-Acnt F +10800 8308 M (MAIKO-ARRAY-TESTS) S +1400 /Helvetica-Acnt F +( and) S +1400 /Helvetica-Bold-Acnt F +( DFASL) S +1400 /Helvetica-Acnt F +( looks like in AUTO) S +grestore savepage restore showpage + +%%Page: 2 2 +%%BeginPageSetup +/savepage save def +0.01 imagesizefactor mul dup scale +%%EndPageSetup +gsave + 0 rotate + 79200 61200 0 0 CLP +/Helvetica /Helvetica-Acnt encodefont +1000 /Helvetica-Acnt F +7200 75600 M (2) S +/Helvetica-Bold /Helvetica-Bold-Acnt encodefont +1400 /Helvetica-Bold-Acnt F +7200 68108 M (Maiko>OBSOLETE>) S +7200 66708 M ( ) S +1400 /Helvetica-Acnt F +(Probably incororated into AUTO>) S +1400 /Helvetica-Acnt F +7200 65308 M ( ) S +1400 /Helvetica-Bold-Acnt F +(AREF-TESTER) S +1400 /Helvetica-Acnt F +7200 63908 M ( ) S +1400 /Helvetica-Bold-Acnt F +10800 63908 M (ARRAY-TESTER.TEST ) S +1400 /Helvetica-Acnt F +( ) S +7200 62508 M ( ) S +1400 /Helvetica-Bold-Acnt F +(FLOAT-TESTER) S +1400 /Helvetica-Acnt F +7200 61108 M ( ) S +1400 /Helvetica-Bold-Acnt F +(MAIKO-UNWIND-TESTS) S +1400 /Helvetica-Acnt F +7200 59708 M ( ) S +1400 /Helvetica-Bold-Acnt F +(TESTER) S +1400 /Helvetica-Acnt F +( \(compiled OK\)) S +7200 58308 M ( ) S +1400 /Helvetica-Bold-Acnt F +(unwindtest) S +1400 /Helvetica-Acnt F +7200 56908 M ( ) S +1400 /Helvetica-Bold-Acnt F +(xclopcodetests) S +1400 /Helvetica-Bold-Acnt F +7200 54108 M (Library>) S +1400 /Helvetica-Acnt F +7200 52708 M ( 4045xlpstream> junk) S +7200 51308 M ( Auto> junk\(!\)) S +1400 /Helvetica-Bold-Acnt F +7200 45708 M (loops>) S +7200 44308 M ( LOOPS-SETUP.TEDIT) S +7200 42908 M ( LOOPS-TESTER-.... ) S +1400 /Helvetica-Acnt F +(files) S +1400 /Helvetica-Bold-Acnt F +7200 40108 M (test>Lyric>) S +7200 38708 M ( ) S +1400 /Helvetica-Acnt F +(\(old-versions of) S +1400 /Helvetica-Bold-Acnt F +( DO-TEST .dfasl ) S +1400 /Helvetica-Acnt F +(and) S +1400 /Helvetica-Bold-Acnt F +( .tedit\)) S +7200 35908 M (Tools>) S +1400 /Helvetica-Bold-Acnt F +10800 34508 M (AUTOTEST.TEDIT) S +1400 /Helvetica-Acnt F +( \(originql AUTOTEST.TEDIT-orig\)) S +7200 33108 M ( ) S +1400 /Helvetica-Bold-Acnt F +10800 33108 M (AUTOTEST & .DFASL) S +1400 /Helvetica-Acnt F +( framework for running tests) S +7200 30308 M ( ) S +1400 /Helvetica-Bold-Acnt F +(DO-TEST & .DFASL ) S +1400 /Helvetica-Acnt F +(\(copied newer version from Medley) S +12000 28908 M (internal/library\)) S +7200 27508 M ( ) S +1400 /Helvetica-Bold-Acnt F +(DO-TEST.TEDIT) S +1400 /Helvetica-Acnt F +( on Writing Software Tests) S +7200 26108 M ( \(many other files not reviewed yet\)) S +grestore savepage restore showpage + +%%Trailer diff --git a/internal/test/tools/AUTOTEST b/internal/test/tools/AUTOTEST index 48b8c82d..d9945d59 100644 --- a/internal/test/tools/AUTOTEST +++ b/internal/test/tools/AUTOTEST @@ -1,1693 +1 @@ -(FILECREATED "16-Jul-85 15:52:21" {DANTE}AUTOTEST.;7 67003 - - changes to: (FNS AT.SHOW.STARTTIME AUTOTESTER AT.MAKETIMEWINDOW AT.SHOW.ENDTIME AT.SHOW.TESTID - AT.SHOW.TESTSUITE AT.REPAINT.TIMEW AT.TESTCOMMAND AT.UPDATEAUTOTESTERITEMS - AT.SINGLE-TEST SINGLE-TEST AT.ABORTCOMMAND AT.RESUMECOMMAND AT.CLOSEFN - AT.PAUSECOMMAND TEST-MESSAGE AT.COMMANDDISPATCH AT.HARDCOPYFN AT.PRINTCOMMAND - AT.PRINTHEADINGSON AT.PRINTANDGETREGION GETPRINTFILE AT.GETPRINTDESTINATION) - (VARS AUTOTESTCOMS ATICON) - - previous date: "20-Jun-85 17:12:30" {DANTE}AUTOTEST.;22) - - -(* Copyright (c) 1985 by XEROX Corporation. All rights reserved.) - -(PRETTYCOMPRINT AUTOTESTCOMS) - -(RPAQQ AUTOTESTCOMS [(FILES ATTACHEDWINDOW ICONW) - [VARS [ATMENUITEMS (QUOTE ((TEST TEST - "Tests the selected files; middle button to also redirect output.") - (ABORT ABORT "Aborts testing of the selected files.") - (PAUSE PAUSE - "Temporarily pauses in the testing of selected files.") - (RESUME RESUME "Resumes PAUSEd testing.") - (DIRECTORY DIRECTORY - "Does a directory of files in order to create a new set of tests to select.") - (PRINT PRINT -"Prints the results of testing of the selected files; middle button to also select printing destination." - ) - (SUMMARIZE SUMMARIZE - "Prints the results of testing of failed tests from the selected files.") - (QUIT QUIT "Quits testing."] - (ATNOARGITEMS (QUOTE (DIRECTORY QUIT))) - (ATBUSYOKITEMS (QUOTE (ABORT PAUSE RESUME QUIT] - (INITVARS (ATICONFONT (FONTCREATE (QUOTE HELVETICA) - 8 - (QUOTE MRR))) - (DEFAULTAUTOTESTFONT (FONTCREATE (QUOTE GACHA) - 10 - (QUOTE MRR))) - (ATTIMEWINDOWFONT (FONTCREATE (QUOTE GACHA) - 8 - (QUOTE MRR))) - (ATPROMPTFONT (FONTCREATE (QUOTE GACHA) - 8 - (QUOTE MRR))) - (AUTOTESTMENUFONT (FONTCREATE (QUOTE HELVETICA) - 10 - (QUOTE MRR))) - (ATBORDERWIDTH 2) - [ATINFOLISTINGWIDTHS (QUOTE (RESULT (Result . 70) - NAME - (Name . 180) - FILE - (File . 1800] - (ATINFOSHADE 16920) - (ATITEMUNSELECTEDSHADE 0) - (ATITEMSELECTEDSHADE 43605)) - (BITMAPS ATICON ATICONMASK) - (CURSORS AT.RIGHTARROWCURSOR) - (* * Main autotester fns) - (FNS AT AUTOTESTER SINGLE-TEST TEST-MESSAGE) - (COMS (* * commands and major subfunctions) - (FNS AT.TESTCOMMAND AT.ABORTCOMMAND AT.PAUSECOMMAND AT.RESUMECOMMAND - AT.DIRECTORYCOMMAND AT.PRINTCOMMAND AT.QUITCOMMAND) - (FNS AT.COMMANDDISPATCH AT.SELECT AT.UPDATEAUTOTESTERITEMS AT.SINGLE-TEST)) - (* * lower-level window mungers) - (FNS AT.MAKERIGIDWINDOW AT.CLRPROMPTW AT.PRINTHEADINGSON AT.PRINTANDGETREGION - AT.MAKEHEADINGWINDOW AT.MAKECOUNTERWINDOW AT.MAKETIMEWINDOW AT.PROMPTWPRINT - AT.PROMPTWTERPRI AT.SELECTFILE AT.UNSELECTFILE AT.CHANGECOMPLETEMARK - AT.SHOW.NUMCOMPLETED AT.SHOW.NUMFILES AT.SHOW.NUMSELECTED AT.SHOW.NUMSUCCESSFUL - AT.SHOW.ENDTIME AT.SHOW.STARTTIME AT.SHOW.TESTID AT.SHOW.TESTSUITE) - (* * window functions) - (FNS AT.HEADINGWREDISPLAYFN AT.REPAINT.COUNTERW AT.REPAINT.TIMEW AT.ICONFN AT.BUTTONEVENTFN - AT.CURSORMOVEDFN AT.CURSOROUTFN AT.REPAINTFN AT.SCROLLFN AT.RIGHTBUTTONFN - AT.MENU.WHENSELECTEDFN AT.CLOSEFN AT.HARDCOPYFN) - (* * odds and ends) - (FNS AT.FETCHFILENAME AT.STARTOFNAME AT.STARTUP AT.CREATEPRINTSPEC AT.FINDTESTBUCKET - AT.PROMPTFORINPUT AT.GETALLFILEINFO AT.GETPRINTDESTINATION AT.\ItemWithTag) - (DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS (AT.MARKXPOS 16)) - (RECORDS ATPRINTSPEC TESTBUCKET)) - (ADDVARS (BackgroundMenuCommands ("AutomatedTester" (AT) - - "Opens an automated tester window; prompts for directory"))) - (VARS (BackgroundMenu)) - (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA AT) - (NLAML) - (LAMA AT.PROMPTWPRINT]) -(FILESLOAD ATTACHEDWINDOW ICONW) - -(RPAQQ ATMENUITEMS ((TEST TEST "Tests the selected files; middle button to also redirect output.") - (ABORT ABORT "Aborts testing of the selected files.") - (PAUSE PAUSE "Temporarily pauses in the testing of selected files.") - (RESUME RESUME "Resumes PAUSEd testing.") - (DIRECTORY DIRECTORY - "Does a directory of files in order to create a new set of tests to select.") - (PRINT PRINT -"Prints the results of testing of the selected files; middle button to also select printing destination." - ) - (SUMMARIZE SUMMARIZE - "Prints the results of testing of failed tests from the selected files.") - (QUIT QUIT "Quits testing."))) - -(RPAQQ ATNOARGITEMS (DIRECTORY QUIT)) - -(RPAQQ ATBUSYOKITEMS (ABORT PAUSE RESUME QUIT)) - -(RPAQ? ATICONFONT (FONTCREATE (QUOTE HELVETICA) - 8 - (QUOTE MRR))) - -(RPAQ? DEFAULTAUTOTESTFONT (FONTCREATE (QUOTE GACHA) - 10 - (QUOTE MRR))) - -(RPAQ? ATTIMEWINDOWFONT (FONTCREATE (QUOTE GACHA) - 8 - (QUOTE MRR))) - -(RPAQ? ATPROMPTFONT (FONTCREATE (QUOTE GACHA) - 8 - (QUOTE MRR))) - -(RPAQ? AUTOTESTMENUFONT (FONTCREATE (QUOTE HELVETICA) - 10 - (QUOTE MRR))) - -(RPAQ? ATBORDERWIDTH 2) - -(RPAQ? ATINFOLISTINGWIDTHS (QUOTE (RESULT (Result . 70) - NAME - (Name . 180) - FILE - (File . 1800)))) - -(RPAQ? ATINFOSHADE 16920) - -(RPAQ? ATITEMUNSELECTEDSHADE 0) - -(RPAQ? ATITEMSELECTEDSHADE 43605) - -(RPAQ ATICON (READBITMAP)) -(80 80 -"OOOOOOOOOOOOOOOOOOOO" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@COA" -"H@@@@AOOOOOOON@@@GOI" -"H@@@@AOOOOOOON@@@NAM" -"H@@@@AOOOOOOON@@@L@M" -"H@@@@AOOOOOOON@@@L@M" -"H@@@@AOOOOOOON@@@@@M" -"H@@@@AOOOOOOON@@@@@M" -"H@@@@AOOOOOOON@@@@AM" -"HH@HFAOOOOOOONAH@@OI" -"HLAHCAOOOOOOON@L@@OA" -"HFC@AIOOOOOOON@F@@LA" -"HCF@@MOOOOOOON@C@@LA" -"HALGOOOOOOOOOOOOH@LA" -"HALGOOOOOOOOOOOOH@LA" -"HCF@@MOOOOOOON@C@@LA" -"HFC@AIOOOOOOON@F@@LA" -"HLAHCAOOOOOOON@L@@LA" -"HH@HFAOOOOOOONAH@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@@LA" -"H@@@@AOOOOOOON@@@@LA" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@AOOOOOOON@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@@@@@A" -"OOOOOOOOOOOOOOOOOOOO") - -(RPAQ ATICONMASK (READBITMAP)) -(80 80 -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOOOOOO") -(RPAQ AT.RIGHTARROWCURSOR (CURSORCREATE (READBITMAP) 7 9)) -(16 16 -"@@@@" -"@@@@" -"@F@@" -"@GH@" -"@GN@" -"@GOH" -"OOON" -"OOOO" -"OOON" -"@GOH" -"@GN@" -"@GH@" -"@F@@" -"@@@@" -"@@@@" -"@@@@") (* * Main autotester fns) - -(DEFINEQ - -(AT - [NLAMBDA DIR (* scv "23-May-85 11:28") - (AUTOTESTER (OR (CAR (NLAMBDA.ARGS DIR)) - (PROMPTFORWORD "Test directory pattern?" NIL NIL PROMPTWINDOW]) - -(AUTOTESTER - [LAMBDA (FILESPEC) (* scv "15-Jul-85 15:36") - (PROG ((PROMPTWHEIGHT 3) - AUTOTESTWINDOW COMMANDMENUWINDOW COMMANDMENU DIRSTART HEADINGW COUNTERW TIMEW TTYDS) - (COND - ((NULL FILESPEC) - (RETURN))) - (SETQ FILESPEC (DIRECTORY.FILL.PATTERN FILESPEC (QUOTE DCOM) - "")) - (SETQ COMMANDMENU - (create MENU - MENUFONT _ AUTOTESTMENUFONT - ITEMS _ ATMENUITEMS - MENUROWS _ 1 - CENTERFLG _ T - WHENSELECTEDFN _(FUNCTION AT.MENU.WHENSELECTEDFN))) - (SETQ AUTOTESTWINDOW (CREATEW (GETREGION (WIDTHIFWINDOW (fetch IMAGEWIDTH of COMMANDMENU) - (fetch MENUOUTLINESIZE - of COMMANDMENU)) - (HEIGHTIFWINDOW (ITIMES 4 (FONTPROP - DEFAULTAUTOTESTFONT - (QUOTE HEIGHT)) - ) - NIL ATBORDERWIDTH)) - NIL ATBORDERWIDTH)) - (SETQ HEADINGW (AT.MAKEHEADINGWINDOW (GETWINDOWPROP AUTOTESTWINDOW (QUOTE WIDTH)) - DEFAULTAUTOTESTFONT ATBORDERWIDTH - "Automated Tester Window")) - (SETQ COUNTERW (AT.MAKECOUNTERWINDOW (HEIGHTIFWINDOW (FONTPROP DEFAULTAUTOTESTFONT - (QUOTE HEIGHT))) - (WINDOWPROP HEADINGW (QUOTE WIDTH)) - AUTOTESTWINDOW)) - (SETQ TIMEW (AT.MAKETIMEWINDOW (HEIGHTIFWINDOW (FONTPROP ATTIMEWINDOWFONT (QUOTE HEIGHT))) - (WINDOWPROP HEADINGW (QUOTE WIDTH)) - AUTOTESTWINDOW)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE HEADINGWINDOW) - HEADINGW) - (ATTACHWINDOW HEADINGW AUTOTESTWINDOW (QUOTE TOP)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE COUNTERWINDOW) - COUNTERW) - (ATTACHWINDOW COUNTERW HEADINGW (QUOTE TOP)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE TIMEWINDOW) - TIMEW) - (ATTACHWINDOW TIMEW COUNTERW (QUOTE TOP)) - (SETQ COMMANDMENUWINDOW (ATTACHMENU COMMANDMENU AUTOTESTWINDOW (QUOTE TOP))) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE SCROLLFN) - (FUNCTION AT.SCROLLFN)) - (AT.MAKERIGIDWINDOW (GETPROMPTWINDOW AUTOTESTWINDOW PROMPTWHEIGHT ATPROMPTFONT)) - (DSPFONT DEFAULTAUTOTESTFONT AUTOTESTWINDOW) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ICONFN) - (FUNCTION AT.ICONFN)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ICONTITLE) - FILESPEC) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE NUMCOMPLETED) - 0) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE NUMSUCCESSFUL) - 0) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ORIGX) - (DSPXPOSITION NIL AUTOTESTWINDOW)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ORIGY) - (DSPYPOSITION NIL AUTOTESTWINDOW)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE DIRWIDTH) - (GETWINDOWPROP AUTOTESTWINDOW (QUOTE WIDTH))) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE BUTTONEVENTFN) - (FUNCTION AT.BUTTONEVENTFN)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE RIGHTBUTTONFN) - (FUNCTION AT.RIGHTBUTTONFN)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE REPAINTFN) - (FUNCTION AT.REPAINTFN)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE CURSORMOVEDFN) - (FUNCTION AT.CURSORMOVEDFN)) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE CURSOROUTFN) - (FUNCTION AT.CURSOROUTFN)) - (WINDOWADDPROP AUTOTESTWINDOW (QUOTE RESHAPEFN) - (FUNCTION RESHAPEBYREPAINTFN)) - (WINDOWADDPROP AUTOTESTWINDOW (QUOTE SHRINKFN) - (FUNCTION AT.CLOSEFN) - T) - (WINDOWADDPROP AUTOTESTWINDOW (QUOTE CLOSEFN) - (FUNCTION AT.CLOSEFN) - T) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ITEMSPEC) - FILESPEC) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE HARDCOPYFN) - (QUOTE AT.HARDCOPYFN)) - (WINDOWPROP COMMANDMENUWINDOW (QUOTE HARDCOPYFN) - (QUOTE AT.HARDCOPYFN)) - (WINDOWPROP HEADINGW (QUOTE HARDCOPYFN) - (QUOTE AT.HARDCOPYFN)) - (WINDOWPROP COUNTERW (QUOTE HARDCOPYFN) - (QUOTE AT.HARDCOPYFN)) - (WINDOWPROP TIMEW (QUOTE HARDCOPYFN) - (QUOTE AT.HARDCOPYFN)) - (WINDOWPROP (GETPROMPTWINDOW AUTOTESTWINDOW) - (QUOTE HARDCOPYFN) - (QUOTE AT.HARDCOPYFN)) - (SETQ TTYDS (WFROMDS (TTYDISPLAYSTREAM))) - (PUTWINDOWPROP AUTOTESTWINDOW (QUOTE ATDISPLAYSTREAM) - TTYDS) - (WINDOWPROP TTYDS (QUOTE PAGEFULLFN) - (QUOTE NILL)) - (WINDOWPROP TTYDS (QUOTE AUTOTESTER) - AUTOTESTWINDOW) - (ADD.PROCESS (LIST (FUNCTION AT.STARTUP) - AUTOTESTWINDOW COMMANDMENU COMMANDMENUWINDOW) - (QUOTE NAME) - (QUOTE AT-Update)) - (RETURN AUTOTESTWINDOW]) - -(SINGLE-TEST - [LAMBDA (IDENTIFIER EXPRESSION PREDICATE TIMEOUT) (* scv "12-Jul-85 16:22") - (PROG (MAIN PROC RESULT TESTEND) - (SETQ MAIN (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM)) - (QUOTE AUTOTESTER))) - (WINDOWPROP MAIN (QUOTE TESTRESULT) - NIL) - (PUTWINDOWPROP MAIN (QUOTE TESTSTART) - NIL) - (PUTWINDOWPROP MAIN (QUOTE TESTEND) - NIL) - [SETQ PROC (ADD.PROCESS (LIST (QUOTE AT.SINGLE-TEST) - (KWOTE IDENTIFIER) - (KWOTE EXPRESSION) - (KWOTE PREDICATE) - (KWOTE TIMEOUT) - (KWOTE (TTYDISPLAYSTREAM)) - (KWOTE (OUTPUT))) - (QUOTE NAME) - (CONCAT (QUOTE SINGLE-TEST-) - IDENTIFIER) - (QUOTE WINDOW) - (WFROMDS (TTYDISPLAYSTREAM] - (WHILE (AND [NULL (SETQ RESULT (WINDOWPROP MAIN (QUOTE TESTRESULT] - (OR (NULL TIMEOUT) - [NULL (SETQ TESTEND (WINDOWPROP MAIN (QUOTE TESTEND] - (LESSP (CLOCK 0) - TESTEND)) - (PROCESSP PROC)) - DO (DISMISS 50)) - (PUTWINDOWPROP MAIN (QUOTE TESTID) - NIL) - (AT.SHOW.TESTID MAIN) - (PUTWINDOWPROP MAIN (QUOTE STARTTIME) - NIL) - (AT.SHOW.STARTTIME MAIN) - (PUTWINDOWPROP MAIN (QUOTE ENDTIME) - NIL) - (AT.SHOW.ENDTIME MAIN) - (IF (NULL RESULT) - THEN (TEST-MESSAGE IDENTIFIER "timed out, timeout" TIMEOUT) - (DEL.PROCESS PROC) - (RETURN NIL) - ELSE (RETURN (CAR RESULT]) - -(TEST-MESSAGE - [LAMBDA (IDENTIFIER TEXT INFO) (* scv " 3-Jul-85 12:07") - (printout NIL "===> Test " IDENTIFIER ": " TEXT ": " INFO T]) -) - (* * commands and major subfunctions) - -(DEFINEQ - -(AT.TESTCOMMAND - [LAMBDA (FILEENTRY KEY WINDOW STDOUT) (* scv "12-Jul-85 14:21") - (PROG (FILENAME NUM ITEMMAP RESULT) - (BLOCK) - (OUTPUT STDOUT) - [WINDOWPROP WINDOW (QUOTE TESTSUITE) - (fetch (ATPRINTSPEC LABEL) of (CADR (fetch (TESTBUCKET ITEM) of FILEENTRY] - (AT.SHOW.TESTSUITE WINDOW) - (SETQ FILENAME (fetch (TESTBUCKET FILENAME) of FILEENTRY)) - (SETQ NUM (fetch (TESTBUCKET #) of FILEENTRY)) - (SETQ ITEMMAP (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) - (LISPXEVAL (LIST (QUOTE LOAD) - (LIST (QUOTE QUOTE) - FILENAME))) - [SETQ RESULT (LISPXEVAL (LIST (FILENAMEFIELD FILENAME (QUOTE NAME)) - (LIST (QUOTE QUOTE) - (PACKFILENAME (QUOTE NAME) - "" - (QUOTE EXTENSION) - "" - (QUOTE VERSION) - "" - (QUOTE BODY) - FILENAME] - (replace (TESTBUCKET COMPLETED?) of FILEENTRY with T) - [WINDOWPROP WINDOW (QUOTE NUMCOMPLETED) - (ADD1 (WINDOWPROP WINDOW (QUOTE NUMCOMPLETED] - (replace (TESTBUCKET SUCCESSFUL?) of FILEENTRY with RESULT) - [if RESULT - then (WINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL) - (ADD1 (WINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL] - (AT.SHOW.NUMCOMPLETED WINDOW) - (AT.SHOW.NUMSUCCESSFUL WINDOW) - [replace (TESTBUCKET ITEM) of FILEENTRY with (CONS [create ATPRINTSPEC - LABEL _(if RESULT - then (QUOTE pass) - else (QUOTE FAIL)) - WIDTH _(fetch (ATPRINTSPEC - WIDTH) - of - (LISTGET - ATINFOLISTINGWIDTHS - (QUOTE RESULT] - (CDR (fetch (TESTBUCKET ITEM) - of FILEENTRY] - (SETQ ITEMMAP (for I in ITEMMAP collect (if (EQP NUM (fetch (TESTBUCKET #) of I)) - then FILEENTRY - else I))) - (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP) - ITEMMAP) - (UNDOLISPX1 (LISPXFIND LISPXHISTORY (LIST (CADR LISPXHISTORY)) - (QUOTE ENTRY) - NIL)) - (UNDOLISPX1 (LISPXFIND LISPXHISTORY (LIST (SUB1 (CADR LISPXHISTORY))) - (QUOTE ENTRY) - NIL)) - (REDISPLAYW WINDOW (fetch (TESTBUCKET ITEMREGION) of FILEENTRY)) - (WINDOWPROP WINDOW (QUOTE TESTSUITE) - NIL) - (AT.SHOW.TESTSUITE WINDOW) - (OUTPUT T]) - -(AT.ABORTCOMMAND - [LAMBDA (KEY WINDOW) (* scv "12-Jul-85 16:19") - (PROG (PAUSED? PAUSE) - (SETQ PAUSED? (GETWINDOWPROP WINDOW (QUOTE PAUSESTART))) - (if (NOT PAUSED?) - then (SETQ PAUSE (CLOCK 0)) - (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) - PAUSE)) - (if (MOUSECONFIRM "Are you sure? " - "Click left button to ABORT tests, right button to RESUME tests." - (GETPROMPTWINDOW (MAINWINDOW WINDOW T))) - then [PROG (PROC) - (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) - (if PROC - then (DEL.PROCESS PROC) - (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) - NIL) - else (AT.CLRPROMPTW WINDOW) - (AT.PROMPTWPRINT WINDOW "No tests in process.") - (if (NOT PAUSED?) - then (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) - NIL] - else (if (NOT PAUSED?) - then (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) - NIL) - (if (GETWINDOWPROP WINDOW (QUOTE TESTEND)) - then (PUTWINDOWPROP WINDOW (QUOTE ENDTIME) - (PLUS (GETWINDOWPROP WINDOW (QUOTE ENDTIME)) - (IQUOTIENT (DIFFERENCE (CLOCK 0) - PAUSE) - 1000))) - (AT.SHOW.ENDTIME (MAINWINDOW WINDOW T)) - (PUTWINDOWPROP WINDOW (QUOTE TESTEND) - (PLUS (GETWINDOWPROP WINDOW (QUOTE TESTEND)) - (DIFFERENCE (CLOCK 0) - PAUSE]) - -(AT.PAUSECOMMAND - [LAMBDA (KEY WINDOW) (* scv " 2-Jul-85 15:29") - (PROG (PROC) - (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) - (if PROC - then (SUSPEND.PROCESS PROC) - (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) - (CLOCK 0)) - else (AT.CLRPROMPTW WINDOW) - (AT.PROMPTWPRINT WINDOW "No tests in process."]) - -(AT.RESUMECOMMAND - [LAMBDA (KEY WINDOW) (* scv "12-Jul-85 16:19") - (PROG (PROC PAUSE) - (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) - (if PROC - then (if (SETQ PAUSE (GETWINDOWPROP WINDOW (QUOTE PAUSESTART))) - then (PUTWINDOWPROP WINDOW (QUOTE PAUSESTART) - NIL) - [if (GETWINDOWPROP WINDOW (QUOTE TESTEND)) - then (PUTWINDOWPROP WINDOW (QUOTE ENDTIME) - (PLUS (GETWINDOWPROP WINDOW (QUOTE ENDTIME)) - (IQUOTIENT (DIFFERENCE (CLOCK 0) - PAUSE) - 1000))) - (AT.SHOW.ENDTIME (MAINWINDOW WINDOW T)) - (PUTWINDOWPROP WINDOW (QUOTE TESTEND) - (PLUS (GETWINDOWPROP WINDOW (QUOTE TESTEND)) - (DIFFERENCE (CLOCK 0) - PAUSE] - (WAKE.PROCESS PROC) - else (AT.CLRPROMPTW WINDOW) - (AT.PROMPTWPRINT WINDOW "No tests paused.")) - else (AT.CLRPROMPTW WINDOW) - (AT.PROMPTWPRINT WINDOW "No tests in process."]) - -(AT.DIRECTORYCOMMAND - [LAMBDA (KEY WINDOW) (* scv "20-Jun-85 12:58") - (PROG (FILESPEC) - (AT.CLRPROMPTW WINDOW) - (if (NULL (SETQ FILESPEC (AT.PROMPTFORINPUT "New test directory pattern? " - (GETWINDOWPROP WINDOW (QUOTE ITEMSPEC)) - WINDOW))) - then (RETURN)) - (PUTWINDOWPROP WINDOW (QUOTE ICONTITLE) - FILESPEC) - (PUTWINDOWPROP WINDOW (QUOTE ITEMSPEC) - (DIRECTORY.FILL.PATTERN FILESPEC (QUOTE DCOM) - "")) - (RETURN T]) - -(AT.PRINTCOMMAND - [LAMBDA (FILEENTRY KEY WINDOW IMAGESTREAM) (* scv " 2-Jul-85 10:36") - (PROG (XPOS FONTWIDTH) - (SETQ FONTWIDTH (CHARWIDTH (CHCON1 "M") - (DSPFONT NIL IMAGESTREAM))) - (SETQ XPOS (DSPLEFTMARGIN NIL IMAGESTREAM)) - (for I in (fetch (TESTBUCKET ITEM) of FILEENTRY) - do (printout IMAGESTREAM (fetch (ATPRINTSPEC LABEL) of I)) - (DSPXPOSITION (SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of I) - FONTWIDTH))) - IMAGESTREAM)) - (TERPRI IMAGESTREAM]) - -(AT.QUITCOMMAND - [LAMBDA (KEY WINDOW) (* scv "31-May-85 12:49") - (CLOSEW WINDOW]) -) -(DEFINEQ - -(AT.COMMANDDISPATCH - [LAMBDA (ITEM MENU KEY) (* scv " 3-Jul-85 11:53") - (PROG (WINDOW ATUPDATE? FILELIST ITEMMAP NUMCOMPLETED NUMSUCCESSFUL FILE XPOS STDOUT) - (SETQ WINDOW (WINDOWPROP (WFROMMENU MENU) - (QUOTE MAINWINDOW))) - (COND - ((FMEMB (CADR ITEM) - ATBUSYOKITEMS)) - ((GETWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY)) - (AT.PROMPTWPRINT WINDOW "The autotester is busy.") - (RETURN))) - (COND - ((EQUAL (CADR ITEM) - (QUOTE "")) - (RETURN))) - (SETQ ITEMMAP (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) - (OR (FMEMB (CADR ITEM) - ATNOARGITEMS) - [SETQ FILELIST (for INDEX in (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS)) - collect (CAR (NTH ITEMMAP INDEX] - (PROGN (AT.PROMPTWPRINT WINDOW "No tests are selected") - (RETURN))) - (RESETLST (RESETSAVE NIL (LIST (QUOTE SHADEITEM) - ITEM MENU ATITEMUNSELECTEDSHADE)) - [RESETSAVE NIL (LIST (FUNCTION [LAMBDA (W P) - (PUTWINDOWPROP W (QUOTE AUTOTESTERBUSY) - P]) - WINDOW - (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY] - (PUTWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY) - T) - (SHADEITEM ITEM MENU ATITEMSELECTEDSHADE) - [SELECTQ (CADR ITEM) - [TEST (RESETLST (RESETSAVE NIL (LIST (QUOTE PUTWINDOWPROP) - WINDOW - (QUOTE TESTPROCESS) - NIL)) - [RESETSAVE NIL (LIST (QUOTE SETTOPVAL) - (QUOTE HELPFLAG) - (GETTOPVAL (QUOTE HELPFLAG] - (RESETSAVE NIL (LIST (QUOTE SET) - (QUOTE HELPFLAG) - HELPFLAG)) - (PUTWINDOWPROP WINDOW (QUOTE TESTPROCESS) - (THIS.PROCESS)) - (SETTOPVAL (QUOTE HELPFLAG) - NIL) - (SETQ HELPFLAG NIL) - [SETQ STDOUT (if (EQ KEY (QUOTE LEFT)) - then T - else (OPENFILE (AT.PROMPTFORINPUT - "Name of file to direct output to? " - "" - WINDOW) - (QUOTE OUTPUT] - (SETQ NUMCOMPLETED (WINDOWPROP WINDOW (QUOTE - NUMCOMPLETED))) - (SETQ NUMSUCCESSFUL (WINDOWPROP WINDOW (QUOTE - NUMSUCCESSFUL))) - [for FILEENTRY in ITEMMAP - do (if (AND (FMEMB (fetch (TESTBUCKET #) - of FILEENTRY) - (WINDOWPROP WINDOW (QUOTE - CURRENTTESTNUMBERS))) - (fetch (TESTBUCKET COMPLETED?) - of FILEENTRY)) - then (SETQ NUMCOMPLETED (SUB1 NUMCOMPLETED)) - (replace (TESTBUCKET COMPLETED?) - of FILEENTRY with NIL) - (if (fetch (TESTBUCKET SUCCESSFUL?) - of FILEENTRY) - then (SETQ NUMSUCCESSFUL - (SUB1 NUMSUCCESSFUL)) - (replace (TESTBUCKET SUCCESSFUL?) - of FILEENTRY with NIL] - (WINDOWPROP WINDOW (QUOTE NUMCOMPLETED) - NUMCOMPLETED) - (WINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL) - NUMSUCCESSFUL) - (AT.SHOW.NUMCOMPLETED WINDOW) - (AT.SHOW.NUMSUCCESSFUL WINDOW) - (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP) - ITEMMAP) - (REDISPLAYW WINDOW) - (TTYDISPLAYSTREAM (WINDOWPROP WINDOW (QUOTE - ATDISPLAYSTREAM))) - (CLEARW (WINDOWPROP WINDOW (QUOTE ATDISPLAYSTREAM))) - (for FILEENTRY in FILELIST - do (AT.TESTCOMMAND FILEENTRY KEY WINDOW STDOUT)) - (if (NEQ STDOUT T) - then (CLOSEF STDOUT] - (ABORT (AT.ABORTCOMMAND KEY WINDOW)) - (PAUSE (AT.PAUSECOMMAND KEY WINDOW)) - (RESUME (AT.RESUMECOMMAND KEY WINDOW)) - (DIRECTORY (SETQ ATUPDATE? (AT.DIRECTORYCOMMAND KEY WINDOW))) - (PRINT (SETQ FILE (AT.GETPRINTDESTINATION KEY)) - (printout FILE "Testing results for " (WINDOWPROP WINDOW - (QUOTE ITEMSPEC) - ) - ":" T T) - (SETQ XPOS (DSPLEFTMARGIN NIL FILE)) - (for I on ATINFOLISTINGWIDTHS by (CDDR I) - do (printout FILE (fetch (ATPRINTSPEC LABEL) - of (CADR I))) - (DSPXPOSITION [SETQ XPOS - (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC - WIDTH) - of (CADR I)) - (CHARWIDTH (CHCON1 - "M") - (DSPFONT - NIL FILE] - FILE)) - (TERPRI FILE) - (for FILEENTRY in FILELIST do (AT.PRINTCOMMAND FILEENTRY KEY - WINDOW FILE)) - (CLOSEF FILE)) - (SUMMARIZE (SETQ FILE (AT.GETPRINTDESTINATION KEY)) - (printout FILE "Testing summary for " (WINDOWPROP - WINDOW - (QUOTE ITEMSPEC)) - ":" T T) - (SETQ XPOS (DSPLEFTMARGIN NIL FILE)) - (for I on ATINFOLISTINGWIDTHS by (CDDR I) - do (printout FILE (fetch (ATPRINTSPEC LABEL) - of (CADR I))) - (DSPXPOSITION [SETQ XPOS - (PLUS XPOS - (ITIMES (fetch (ATPRINTSPEC - WIDTH) - of (CADR I)) - (CHARWIDTH (CHCON1 "M") - (DSPFONT - NIL FILE] - FILE)) - (TERPRI FILE) - (for FILEENTRY in FILELIST - do (if (NULL (fetch (TESTBUCKET SUCCESSFUL?) of FILEENTRY)) - then (AT.PRINTCOMMAND FILEENTRY KEY WINDOW FILE))) - (CLOSEF FILE)) - (QUIT (AT.QUITCOMMAND KEY WINDOW)) - (LET ((FN (CADR ITEM))) - (if (EQ (CAR FN) - (QUOTE FUNCTION)) - then (APPLY* (CADR FN) - FILELIST KEY WINDOW) - else (SHOULDNT] - (COND - (ATUPDATE? (AT.UPDATEAUTOTESTERITEMS (WINDOWPROP WINDOW (QUOTE ITEMSPEC)) - WINDOW]) - -(AT.SELECT - [LAMBDA (WINDOW) (* scv "22-May-85 15:32") - (PROG (AUTOTESTERITEMMAP TEST SETSEL ADDSEL EXTEND CURRENT#S TEST# FIRST# LAST#) - (OR (SETQ SETSEL (MOUSESTATE LEFT)) - (SETQ ADDSEL (LASTMOUSESTATE MIDDLE)) - (SETQ EXTEND (LASTMOUSESTATE RIGHT)) - (RETURN)) - (SETQ AUTOTESTERITEMMAP (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) - (SETQ TEST (AT.FINDTESTBUCKET WINDOW)) - (COND - ((NULL TEST) - (RETURN))) - [COND - (SETSEL (for TEST# in (GETWINDOWUSERPROP WINDOW (QUOTE CURRENTTESTNUMBERS)) - do (AT.UNSELECTFILE (CAR (FNTH AUTOTESTERITEMMAP TEST#)) - WINDOW)) - (AT.SELECTFILE TEST WINDOW)) - (ADDSEL (if (fetch (TESTBUCKET SELECTED?) of TEST) - then (AT.UNSELECTFILE TEST WINDOW) - else (AT.SELECTFILE TEST WINDOW))) - (EXTEND (* have to find all the messages between TEST and the  - one selected *) - (COND - ([SETQ CURRENT#S (SORT (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS] - (SETQ TEST# (fetch (TESTBUCKET #) of TEST)) - [COND - [(ILESSP TEST# (CAR CURRENT#S)) (* before *) - (SETQ FIRST# TEST#) - (SETQ LAST# (SUB1 (CAR CURRENT#S] - (T (SETQ LAST# TEST#) (* after *) - (SETQ FIRST# (ADD1 (CAR (LAST CURRENT#S] - (for I from FIRST# to LAST# do (AT.SELECTFILE (CAR (NTH AUTOTESTERITEMMAP I)) - WINDOW] - (AT.SHOW.NUMSELECTED WINDOW]) - -(AT.UPDATEAUTOTESTERITEMS - [LAMBDA (ITEMSPEC WINDOW) (* scv "12-Jul-85 14:07") - (PROG ((INFOWANTED (QUOTE (RESULT NAME FILE))) - HEADINGWINDOW FILEGENERATOR FILENAME FILEINFO MAXWIDTH AUTOTESTERITEMMAP) - [SETQ FILEGENERATOR (\GENERATEFILES ITEMSPEC (QUOTE (NAME)) - (QUOTE (SORT RESETLST] - (SETQ HEADINGWINDOW (GETWINDOWPROP WINDOW (QUOTE HEADINGWINDOW))) - (WINDOWPROP HEADINGWINDOW (QUOTE TITLE) - "Auto Tester") - (CLEARW (WINDOWPROP WINDOW (QUOTE COUNTERWINDOW))) - (PUTWINDOWPROP WINDOW (QUOTE EXTENT) - NIL) (* set EXTENT to NIL while updating) - (PUTWINDOWPROP WINDOW (QUOTE INFOGOTTEN) - INFOWANTED) - (PUTWINDOWPROP WINDOW (QUOTE DIRWIDTH) - (SETQ MAXWIDTH (AT.PRINTHEADINGSON HEADINGWINDOW INFOWANTED))) - (DSPRIGHTMARGIN 32767 WINDOW) - (CLEARW WINDOW) - [SETQ AUTOTESTERITEMMAP (while (SETQ FILENAME (\GENERATENEXTFILE FILEGENERATOR)) - as ITEMCOUNT from 1 bind ITEM bind STARTOFNAME - collect (if (LISTP FILENAME) - then (SETQ FILENAME (CONCATCODES FILENAME))) - (SETQ FILEINFO (AT.GETALLFILEINFO FILENAME FILEGENERATOR - INFOWANTED)) - (create TESTBUCKET - FILENAME _ FILENAME - # _ ITEMCOUNT - ITEM _[SETQ ITEM - (AT.CREATEPRINTSPEC FILEINFO INFOWANTED - (OR STARTOFNAME - (SETQ STARTOFNAME - (AT.STARTOFNAME - FILENAME ITEMSPEC] - ITEMREGION _(AT.PRINTANDGETREGION ITEM WINDOW - AT.MARKXPOS 10) - SELECTED? _ NIL - COMPLETED? _ NIL - SUCCESSFUL? _(QUOTE ?] - (PUTWINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP) - AUTOTESTERITEMMAP) - (PUTWINDOWPROP WINDOW (QUOTE EXTENT) - (if AUTOTESTERITEMMAP - then [create REGION - LEFT _ 0 - BOTTOM _[fetch (REGION BOTTOM) - of (fetch (TESTBUCKET ITEMREGION) - of (CAR (LAST AUTOTESTERITEMMAP] - WIDTH _ MAXWIDTH - HEIGHT _(IDIFFERENCE (fetch (REGION PTOP) - of (fetch (TESTBUCKET ITEMREGION) - of (CAR AUTOTESTERITEMMAP))) - (fetch (REGION BOTTOM) - of (fetch (TESTBUCKET ITEMREGION) - of (CAR (LAST - AUTOTESTERITEMMAP] - else (AT.CLRPROMPTW WINDOW) - (AT.PROMPTWPRINT WINDOW "No files in group " ITEMSPEC) - NIL)) - (PUTWINDOWPROP HEADINGWINDOW (QUOTE TITLE) - (CONCAT (WINDOWPROP WINDOW (QUOTE ITEMSPEC)) - " tester")) - (PUTWINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS) - NIL) - (PUTWINDOWPROP WINDOW (QUOTE CURRENTITEM) - NIL) - (PUTWINDOWPROP WINDOW (QUOTE NUMCOMPLETED) - 0) - (PUTWINDOWPROP WINDOW (QUOTE NUMSUCCESSFUL) - 0) - (AT.SHOW.NUMFILES WINDOW) - (AT.SHOW.NUMSELECTED WINDOW) - (AT.SHOW.NUMCOMPLETED WINDOW) - (AT.SHOW.NUMSUCCESSFUL WINDOW) - (AT.SHOW.TESTSUITE WINDOW) - (AT.SHOW.TESTID WINDOW) - (AT.SHOW.STARTTIME WINDOW) - (AT.SHOW.ENDTIME WINDOW]) - -(AT.SINGLE-TEST - [LAMBDA (IDENTIFIER EXPRESSION PREDICATE TIMEOUT TTYDS STDOUT) - (* scv "12-Jul-85 16:08") - (PROG (RESULT MAIN START) - (TTYDISPLAYSTREAM TTYDS) - (OUTPUT STDOUT) - (SETQ MAIN (WINDOWPROP (WFROMDS TTYDS) - (QUOTE AUTOTESTER))) - (PUTWINDOWPROP MAIN (QUOTE TESTID) - IDENTIFIER) - (AT.SHOW.TESTID MAIN) - (PUTWINDOWPROP MAIN (QUOTE STARTTIME) - (IDATE)) - (AT.SHOW.STARTTIME MAIN) - (IF TIMEOUT - THEN (* The following assumes that the date format used by  - IDATE and GDATE is in seconds.) - (PUTWINDOWPROP MAIN (QUOTE ENDTIME) - (PLUS (IDATE) - (QUOTIENT TIMEOUT 1000))) - (AT.SHOW.ENDTIME MAIN)) - (BLOCK) - (SETQ START (CLOCK 0)) - (PUTWINDOWPROP MAIN (QUOTE TESTSTART) - START) - (PUTWINDOWPROP MAIN (QUOTE TESTEND) - (if TIMEOUT - then (PLUS START TIMEOUT) - else -1)) - (SETQ RESULT (ERRORSET EXPRESSION T)) - (PUTWINDOWPROP MAIN (QUOTE TESTSTART) - NIL) - (PUTWINDOWPROP MAIN (QUOTE TESTEND) - NIL) - (BLOCK) - (if (NULL RESULT) - then (TEST-MESSAGE IDENTIFIER "got an error in expression" EXPRESSION) - (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) - (QUOTE (NIL))) - elseif (EQ (CAR RESULT) - (QUOTE NOBIND)) - then (TEST-MESSAGE IDENTIFIER "returned NOBIND in expression" EXPRESSION) - (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) - (QUOTE (NIL))) - else [SETQ RESULT (ERSETQ (APPLY* PREDICATE (CAR RESULT] - (BLOCK) - (if (NULL RESULT) - then (TEST-MESSAGE IDENTIFIER "got an error in predicate" PREDICATE) - (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) - (QUOTE (NIL))) - elseif (EQ (CAR RESULT) - (QUOTE NOBIND)) - then (TEST-MESSAGE IDENTIFIER "returned NOBIND in predicate" PREDICATE) - (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) - (QUOTE (NIL))) - else (PUTWINDOWPROP MAIN (QUOTE TESTRESULT) - RESULT]) -) - (* * lower-level window mungers) - -(DEFINEQ - -(AT.MAKERIGIDWINDOW - [LAMBDA (WINDOW) (* lmm "14-Sep-84 16:22") - - (* * make the argument window immutable w/r/to attachedwindow package) - - - (PROG [(HEIGHT (fetch (REGION HEIGHT) of (GETWINDOWPROP WINDOW (QUOTE REGION] - (PUTWINDOWPROP WINDOW (QUOTE MINSIZE) - (CONS 0 HEIGHT)) - (PUTWINDOWPROP WINDOW (QUOTE MAXSIZE) - (CONS SCREENWIDTH HEIGHT]) - -(AT.CLRPROMPTW - [LAMBDA (MAINWINDOW) (* Jellinek " 6-May-84 16:48") - (CLEARW (CAR (GETWINDOWPROP MAINWINDOW (QUOTE PROMPTWINDOW]) - -(AT.PRINTHEADINGSON - [LAMBDA (WINDOW HEADINGS) (* scv " 1-Jul-85 10:35") - (PROG ((totalwidth 0) - BOTTOM) - (DSPRIGHTMARGIN 32000 WINDOW) - (DSPTEXTURE BLACKSHADE WINDOW) - (DSPOPERATION (QUOTE INVERT) - WINDOW) - (DSPFILL NIL BLACKSHADE (QUOTE REPLACE) - WINDOW) - (for HEADING in ATINFOLISTINGWIDTHS by (CDDR HEADING) bind word width (pos _ AT.MARKXPOS) - when (FMEMB HEADING HEADINGS) - do (SETQ word (fetch (ATPRINTSPEC LABEL) of (LISTGET ATINFOLISTINGWIDTHS HEADING))) - (SETQ width (ITIMES (fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS - HEADING)) - (CHARWIDTH (CHCON1 "M") - DEFAULTAUTOTESTFONT))) - (SETQ totalwidth (IPLUS totalwidth width)) - (DSPXPOSITION pos WINDOW) - (PRIN3 word WINDOW) - (add pos width)) - (PUTWINDOWPROP WINDOW (QUOTE EXTENT) - (create REGION - LEFT _ 0 - BOTTOM _[SETQ BOTTOM (IPLUS (DSPYPOSITION NIL WINDOW) - (FONTPROP WINDOW (QUOTE ASCENT] - WIDTH _ totalwidth - HEIGHT _(IDIFFERENCE (GETWINDOWPROP WINDOW (QUOTE HEIGHT)) - BOTTOM))) - (RETURN totalwidth]) - -(AT.PRINTANDGETREGION - [LAMBDA (PRINTSPEC STREAM LFTMARGIN MINSPACE) (* scv " 1-Jul-85 11:29") - (* prints PRINTSPEC on WINDOW and returns the box taken - by the characters.) - (PROG (YSTART YEND HEIGHT) - (DSPXPOSITION LFTMARGIN STREAM) - (SETQ YSTART (DSPYPOSITION NIL STREAM)) - (for SPEC in PRINTSPEC bind OLDX PRETTYWIDTH - do (SETQ OLDX (DSPXPOSITION NIL STREAM)) - [SETQ PRETTYWIDTH (ITIMES (fetch (ATPRINTSPEC WIDTH) of SPEC) - (CHARWIDTH (CHCON1 "M") - (DSPFONT NIL STREAM] - (COND - ((fetch (ATPRINTSPEC LABEL) of SPEC) - (PRIN3 (fetch (ATPRINTSPEC LABEL) of SPEC) - STREAM) - (PRIN3 " " STREAM))) (* If any single item won't fit, skip a line and  - continue) - (if (IGEQ (IDIFFERENCE (DSPXPOSITION NIL STREAM) - OLDX) - PRETTYWIDTH) - then (TERPRI STREAM)) - (DSPXPOSITION (IPLUS OLDX PRETTYWIDTH) - STREAM)) - (SETQ YEND (DSPYPOSITION NIL STREAM)) - (RETURN (PROG1 (create REGION - LEFT _ LFTMARGIN - BOTTOM _(IDIFFERENCE YEND (FONTPROP STREAM (QUOTE DESCENT))) - HEIGHT _(IPLUS (IDIFFERENCE YSTART YEND) - (FONTPROP STREAM (QUOTE HEIGHT))) - WIDTH _(IDIFFERENCE (DSPXPOSITION NIL STREAM) - LFTMARGIN)) - (TERPRI STREAM]) - -(AT.MAKEHEADINGWINDOW - [LAMBDA (WIDTH FONT BORDER TITLE) (* scv "23-May-85 11:56") - (PROG (PWINDOW) - (SETQ PWINDOW (CREATEW (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ WIDTH - HEIGHT _(HEIGHTIFWINDOW (FONTPROP FONT (QUOTE HEIGHT)) - TITLE BORDER)) - TITLE BORDER T)) - (DSPFONT FONT PWINDOW) - (PUTWINDOWPROP PWINDOW (QUOTE PAGEFULLFN) - (FUNCTION NILL)) - (PUTWINDOWPROP PWINDOW (QUOTE NOSCROLLBARS) - T) - (PUTWINDOWPROP PWINDOW (QUOTE SCROLLFN) - (FUNCTION SCROLLBYREPAINTFN)) - (PUTWINDOWPROP PWINDOW (QUOTE REPAINTFN) - (FUNCTION AT.HEADINGWREDISPLAYFN)) - (AT.MAKERIGIDWINDOW PWINDOW) - (RETURN PWINDOW]) - -(AT.MAKECOUNTERWINDOW - [LAMBDA (HEIGHT WIDTH AUTOTESTW) (* scv "30-May-85 16:59") - (LET ((COUNTERW (CREATEW (create REGION - LEFT _ 0 - BOTTOM _ 0 - HEIGHT _(HEIGHTIFWINDOW (FONTPROP DEFAULTAUTOTESTFONT - (QUOTE HEIGHT))) - WIDTH _(WINDOWPROP AUTOTESTW (QUOTE WIDTH))) - NIL NIL T))) - (AT.MAKERIGIDWINDOW COUNTERW) - (WINDOWPROP COUNTERW (QUOTE AUTOTESTERWINDOW) - AUTOTESTW) - (WINDOWPROP COUNTERW (QUOTE REPAINTFN) - (FUNCTION AT.REPAINT.COUNTERW)) - COUNTERW]) - -(AT.MAKETIMEWINDOW - [LAMBDA (HEIGHT WIDTH AUTOTESTW) (* scv "15-Jul-85 15:36") - (LET ((TIMEW (CREATEW (create REGION - LEFT _ 0 - BOTTOM _ 0 - HEIGHT _(HEIGHTIFWINDOW (FONTPROP ATTIMEWINDOWFONT (QUOTE HEIGHT))) - WIDTH _(WINDOWPROP AUTOTESTW (QUOTE WIDTH))) - NIL NIL T))) - (AT.MAKERIGIDWINDOW TIMEW) - (WINDOWPROP TIMEW (QUOTE AUTOTESTERWINDOW) - AUTOTESTW) - (WINDOWPROP TIMEW (QUOTE REPAINTFN) - (FUNCTION AT.REPAINT.TIMEW)) - (DSPFONT ATTIMEWINDOWFONT TIMEW) - TIMEW]) - -(AT.PROMPTWPRINT - [LAMBDA U (* Jellinek " 6-May-84 16:37") - (PROG (WINDOW) - (COND - ((ILESSP U 2) - (ERROR "not enough args to PROMPTWPRINT"))) (* CAR is window, CDR is height in lines) - [SETQ WINDOW (CAR (GETWINDOWPROP (ARG U 1) - (QUOTE PROMPTWINDOW] - (for ITEM from 2 to U do (PRIN1 (ARG U ITEM) - WINDOW]) - -(AT.PROMPTWTERPRI - [LAMBDA (MAINWINDOW) (* Jellinek " 6-May-84 16:37") - (* CAR is prompt window, CDR is height in lines) - (TERPRI (CAR (GETWINDOWPROP MAINWINDOW (QUOTE PROMPTWINDOW]) - -(AT.SELECTFILE - [LAMBDA (FOLDER WINDOW) (* scv "23-May-85 12:10") - (COND - (FOLDER (replace (TESTBUCKET SELECTED?) of FOLDER with T) - (WINDOWADDPROP WINDOW (QUOTE CURRENTTESTNUMBERS) - (fetch (TESTBUCKET #) of FOLDER)) - [WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS) - (SORT (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS] - (\ITEMW.SELECTITEM (LIST (fetch (TESTBUCKET ITEMREGION) of FOLDER)) - WINDOW]) - -(AT.UNSELECTFILE - [LAMBDA (MSG WINDOW) (* scv "28-May-85 12:53") - (COND - (MSG (replace (TESTBUCKET SELECTED?) of MSG with NIL) - [WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS) - (REMOVE (fetch (TESTBUCKET #) of MSG) - (WINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS] - (\ITEMW.DESELECTITEM (LIST (fetch ITEMREGION of MSG)) - WINDOW]) - -(AT.CHANGECOMPLETEMARK - [LAMBDA (TEST WINDOW) (* scv "28-May-85 12:37") - (PROG ((TESTREGION (fetch ITEMREGION of TEST))) - (BITBLT NIL 0 0 WINDOW (fetch (REGION LEFT) of TESTREGION) - (IDIFFERENCE (fetch (REGION PTOP) of TESTREGION) - (IQUOTIENT (FONTPROP WINDOW (QUOTE HEIGHT)) - 2)) - (fetch (REGION WIDTH) of TESTREGION) - 1 - (QUOTE TEXTURE) - (QUOTE INVERT) - BLACKSHADE]) - -(AT.SHOW.NUMCOMPLETED - [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:30") - (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 2)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 3))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - COUNTERW) - (DSPXPOSITION STARTPOSITION COUNTERW) - (PRIN3 "Completed:" COUNTERW) - (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE NUMCOMPLETED)) - PRINTINGREGION COUNTERW]) - -(AT.SHOW.NUMFILES - [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:28") - (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 0)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 1))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - COUNTERW) - (DSPXPOSITION STARTPOSITION COUNTERW) - (PRIN3 "Files:" COUNTERW) - (CENTERPRINTINREGION (LENGTH (WINDOWPROP AUTOTESTERW (QUOTE AUTOTESTERITEMMAP))) - PRINTINGREGION COUNTERW]) - -(AT.SHOW.NUMSELECTED - [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:35") - (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 1)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 2))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - COUNTERW) - (DSPXPOSITION STARTPOSITION COUNTERW) - (PRIN3 "Selected:" COUNTERW) - (CENTERPRINTINREGION (LENGTH (WINDOWPROP AUTOTESTERW (QUOTE CURRENTTESTNUMBERS))) - PRINTINGREGION COUNTERW]) - -(AT.SHOW.NUMSUCCESSFUL - [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:30") - (LET ((COUNTERW (WINDOWPROP AUTOTESTERW (QUOTE COUNTERWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 3)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 4))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP COUNTERW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - COUNTERW) - (DSPXPOSITION STARTPOSITION COUNTERW) - (PRIN3 "Successful:" COUNTERW) - (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE NUMSUCCESSFUL)) - PRINTINGREGION COUNTERW]) - -(AT.SHOW.ENDTIME - [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 16:01") - (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 3)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 4))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - TIMEW) - (DSPXPOSITION STARTPOSITION TIMEW) - (PRIN3 "End:" TIMEW) - (IF (WINDOWPROP AUTOTESTERW (QUOTE ENDTIME)) - THEN (CENTERPRINTINREGION (GDATE (WINDOWPROP AUTOTESTERW (QUOTE ENDTIME))) - PRINTINGREGION TIMEW]) - -(AT.SHOW.STARTTIME - [LAMBDA (AUTOTESTERW) (* scv "15-Jul-85 15:43") - (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 2)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 3))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - TIMEW) - (DSPXPOSITION STARTPOSITION TIMEW) - (PRIN3 "Start:" TIMEW) - (IF (WINDOWPROP AUTOTESTERW (QUOTE STARTTIME)) - THEN (CENTERPRINTINREGION (GDATE (WINDOWPROP AUTOTESTERW (QUOTE STARTTIME))) - PRINTINGREGION TIMEW]) - -(AT.SHOW.TESTID - [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 13:49") - (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 1)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 2))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - TIMEW) - (DSPXPOSITION STARTPOSITION TIMEW) - (PRIN3 "ID:" TIMEW) - (IF (WINDOWPROP AUTOTESTERW (QUOTE TESTID)) - THEN (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE TESTID)) - PRINTINGREGION TIMEW]) - -(AT.SHOW.TESTSUITE - [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 13:47") - (LET ((TIMEW (WINDOWPROP AUTOTESTERW (QUOTE TIMEWINDOW))) - (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 0)) - (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW (QUOTE WIDTH)) - 4) - 1))) - (LET [(PRINTINGREGION (create REGION - LEFT _ STARTPOSITION - WIDTH _(IDIFFERENCE ENDPOSITION STARTPOSITION) - BOTTOM _ 0 - HEIGHT _(WINDOWPROP TIMEW (QUOTE HEIGHT] - (DSPFILL PRINTINGREGION WHITESHADE (QUOTE REPLACE) - TIMEW) - (DSPXPOSITION STARTPOSITION TIMEW) - (PRIN3 "Suite:" TIMEW) - (IF (WINDOWPROP AUTOTESTERW (QUOTE TESTSUITE)) - THEN (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW (QUOTE TESTSUITE)) - PRINTINGREGION TIMEW]) -) - (* * window functions) - -(DEFINEQ - -(AT.HEADINGWREDISPLAYFN - [LAMBDA (WINDOW) (* scv "24-May-85 17:06") - (AT.PRINTHEADINGSON WINDOW (GETWINDOWPROP (GETWINDOWPROP WINDOW (QUOTE MAINWINDOW)) - (QUOTE INFOGOTTEN]) - -(AT.REPAINT.COUNTERW - [LAMBDA (COUNTERWINDOW) (* scv "29-May-85 14:12") - (LET [(AUTOTESTERW (WINDOWPROP COUNTERWINDOW (QUOTE AUTOTESTERWINDOW] - (DSPFILL NIL WHITESHADE (QUOTE REPLACE) - COUNTERWINDOW) - (AT.SHOW.NUMFILES AUTOTESTERW) - (AT.SHOW.NUMSELECTED AUTOTESTERW) - (AT.SHOW.NUMCOMPLETED AUTOTESTERW) - (AT.SHOW.NUMSUCCESSFUL AUTOTESTERW]) - -(AT.REPAINT.TIMEW - [LAMBDA (TIMEWINDOW) (* scv "12-Jul-85 13:16") - (LET [(AUTOTESTERW (WINDOWPROP TIMEWINDOW (QUOTE AUTOTESTERWINDOW] - (DSPFILL NIL WHITESHADE (QUOTE REPLACE) - TIMEWINDOW) - (AT.SHOW.TESTSUITE AUTOTESTERW) - (AT.SHOW.TESTID AUTOTESTERW) - (AT.SHOW.STARTTIME AUTOTESTERW) - (AT.SHOW.ENDTIME AUTOTESTERW]) - -(AT.ICONFN - [LAMBDA (W I) (* scv " 3-Jun-85 14:41") - (PROG (OLDICONREGION) - [SETQ OLDICONREGION (AND I (GETWINDOWPROP I (QUOTE REGION] - (RETURN (TITLEDICONW (create TITLEDICON - ICON _ ATICON - MASK _ ATICONMASK - TITLEREG _(create REGION - LEFT _ 5 - WIDTH _ 70 - BOTTOM _ 45 - HEIGHT _ 75)) - (GETWINDOWPROP W (QUOTE ITEMSPEC)) - ATICONFONT - (AND I (create POSITION - XCOORD _(fetch (REGION LEFT) of OLDICONREGION) - YCOORD _(fetch (REGION BOTTOM) of OLDICONREGION))) - NIL - (QUOTE TOP]) - -(AT.BUTTONEVENTFN - [LAMBDA (WINDOW) (* scv "30-May-85 09:23") - (AT.SELECT WINDOW]) - -(AT.CURSORMOVEDFN - [LAMBDA (WINDOW) (* scv "29-May-85 09:49") - (if (IGEQ AT.MARKXPOS (fetch XCOORD of (CURSORPOSITION NIL WINDOW))) - then (SETCURSOR AT.RIGHTARROWCURSOR) - else (if (NEQ (CURSOR) - DEFAULTCURSOR) - then (SETCURSOR DEFAULTCURSOR]) - -(AT.CURSOROUTFN - [LAMBDA (WINDOW) (* rao: "30-JUN-82 15:49") - (SETCURSOR DEFAULTCURSOR]) - -(AT.REPAINTFN - [LAMBDA (WINDOW R) (* scv "29-May-85 09:45") - (PROG ((AUTOTESTERITEMMAP (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP))) - (HEADINGWINDOW (GETWINDOWPROP WINDOW (QUOTE HEADINGWINDOW))) - (TOP (fetch (REGION TOP) of R)) - [BOTTOM (IDIFFERENCE (fetch (REGION BOTTOM) of R) - (FONTPROP WINDOW (QUOTE ASCENT] - YPOS ITEMSPEC DIRWIDTH STARTOFNAME ATTRS) - (COND - ((NULL AUTOTESTERITEMMAP) - (RETURN))) - (for FILE in AUTOTESTERITEMMAP bind REGION - do (if (AND [IGREATERP TOP (SETQ YPOS (fetch (REGION BOTTOM) - of (SETQ REGION (fetch (TESTBUCKET ITEMREGION) - of FILE] - (ILESSP BOTTOM (fetch (REGION TOP) of REGION))) - then (DSPYPOSITION (IDIFFERENCE (IPLUS (fetch (REGION BOTTOM) of REGION) - (fetch (REGION HEIGHT) of REGION)) - (FONTPROP WINDOW (QUOTE ASCENT))) - WINDOW) - (OR (EQUAL (AT.PRINTANDGETREGION (fetch (TESTBUCKET ITEM) of FILE) - WINDOW AT.MARKXPOS 10) - REGION) - T - (HELP)) - (if (fetch (TESTBUCKET SELECTED?) of FILE) - then (\ITEMW.SELECTITEM (LIST (fetch ITEMREGION of FILE)) - WINDOW)) - (if (fetch (TESTBUCKET COMPLETED?) of FILE) - then (AT.CHANGECOMPLETEMARK FILE WINDOW))) - repeatwhile (ILESSP BOTTOM YPOS]) - -(AT.SCROLLFN - [LAMBDA (WINDOW HORIZ VERT CONTINUOUS?) (* scv "28-May-85 12:45") - - (* * Scroll AT window up/down and right/left. In right/left case, tell heading window to scroll also) - - - - (* * only scroll an integral number of text lines) - - - (if (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY)) - then (AT.CLRPROMPTW WINDOW) - (AT.PROMPTWPRINT WINDOW "The autotester is busy.") - else (COND - ((NOT (ZEROP HORIZ)) - (SCROLLW (GETWINDOWPROP WINDOW (QUOTE HEADINGWINDOW)) - HORIZ VERT CONTINUOUS?))) - (SCROLLBYREPAINTFN WINDOW HORIZ VERT CONTINUOUS?]) - -(AT.RIGHTBUTTONFN - [LAMBDA (WINDOW) (* scv "29-May-85 09:45") - (COND - ((IGREATERP (LASTMOUSEX WINDOW) - AT.MARKXPOS) - (DOWINDOWCOM WINDOW)) - (T (AT.SELECT WINDOW]) - -(AT.MENU.WHENSELECTEDFN - [LAMBDA (Item Menu Key) (* scv "28-May-85 11:03") - (ADD.PROCESS (LIST (FUNCTION AT.COMMANDDISPATCH) - (KWOTE Item) - (KWOTE Menu) - (KWOTE Key)) - (QUOTE NAME) - (PACK (LIST (QUOTE AT-) - (CAR Item]) - -(AT.CLOSEFN - [LAMBDA (WINDOW) (* scv " 2-Jul-85 13:55") - (* did you really want to close up shop?) - - (* * do the right thing; if we are really closing, smash pointers which can cause circularities, so everything gets  - collected) - - - (PROG (PROC) - (SETQ PROC (GETWINDOWPROP WINDOW (QUOTE TESTPROCESS))) - (RETURN (COND - (PROC (SUSPEND.PROCESS PROC) - (if (MOUSECONFIRM "Tests in progress: " - "Click left button to ABORT tests, right button to RESUME tests." - (GETPROMPTWINDOW (MAINWINDOW WINDOW T))) - then (DEL.PROCESS PROC) - (PUTWINDOWPROP (GETWINDOWPROP WINDOW (QUOTE COUNTERWINDOW)) - (QUOTE AUTOTESTERWINDOW) - NIL) - (PUTWINDOWPROP WINDOW (QUOTE ATDISPLAYSTREAM) - NIL) - else (WAKE.PROCESS PROC) - (QUOTE DON'T))) - (T (PUTWINDOWPROP (GETWINDOWPROP WINDOW (QUOTE COUNTERWINDOW)) - (QUOTE AUTOTESTERWINDOW) - NIL) - (PUTWINDOWPROP WINDOW (QUOTE ATDISPLAYSTREAM) - NIL]) - -(AT.HARDCOPYFN - [LAMBDA (WINDOW IMAGESTREAM) (* scv " 1-Jul-85 14:15") - (SETQ WINDOW (MAINWINDOW WINDOW T)) - (PROG (XPOS FONTWIDTH) - (printout IMAGESTREAM "Testing results for " (GETWINDOWPROP WINDOW (QUOTE ITEMSPEC)) - ":" T T) - (SETQ FONTWIDTH (CHARWIDTH (CHCON1 "M") - (DSPFONT NIL IMAGESTREAM))) - (SETQ XPOS (DSPLEFTMARGIN NIL IMAGESTREAM)) - (for I on ATINFOLISTINGWIDTHS by (CDDR I) - do (printout IMAGESTREAM (fetch (ATPRINTSPEC LABEL) of (CADR I))) - (DSPXPOSITION (SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) - of (CADR I)) - FONTWIDTH))) - IMAGESTREAM)) - (TERPRI IMAGESTREAM) - (for FILEENTRY in (for INDEX in (GETWINDOWPROP WINDOW (QUOTE CURRENTTESTNUMBERS)) - collect (CAR (NTH (GETWINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP)) - INDEX))) - do (AT.PRINTCOMMAND FILEENTRY (QUOTE RIGHT) - WINDOW IMAGESTREAM]) -) - (* * odds and ends) - -(DEFINEQ - -(AT.FETCHFILENAME - [LAMBDA (ENTRY) (* scv "24-May-85 16:45") - (fetch (TESTBUCKET FILENAME) of ENTRY]) - -(AT.STARTOFNAME - [LAMBDA (FILENAME SPEC) (* lmm "14-Sep-84 17:59") - (* assume that hosts match) - [SETQ SPEC (SUBSTRING SPEC (ADD1 (OR (LASTCHPOS (CHARCODE }) - SPEC) - 0] - (bind (DIRSTART _(ADD1 (OR (LASTCHPOS (CHARCODE }) - FILENAME) - 0))) - DIREND first (SETQ FILENAME (SUBSTRING FILENAME DIRSTART)) while (SETQ DIREND - (LASTCHPOS (CHARCODE - >) - SPEC)) - do (SETQ SPEC (SUBSTRING SPEC 1 DIREND SPEC)) - [if (STRPOS SPEC FILENAME 1 NIL T NIL (UPPERCASEARRAY)) - then (RETURN (IPLUS DIRSTART (NCHARS SPEC] - (SETQ SPEC (SUBSTRING SPEC 1 -2 SPEC)) - finally (RETURN DIRSTART]) - -(AT.STARTUP - [LAMBDA (WINDOW COMMANDMENU COMMANDMENUWINDOW) (* scv "20-Jun-85 11:05") - (PROG ((DIR (FASSOC (QUOTE DIRECTORY) - ATMENUITEMS))) - (RESETLST (RESETSAVE NIL (LIST (QUOTE SHADEITEM) - DIR COMMANDMENU WHITESHADE)) - (RESETSAVE NIL (LIST (FUNCTION [LAMBDA (W P) - (PUTWINDOWPROP W (QUOTE AUTOTESTERBUSY) - P]) - WINDOW NIL)) - (SHADEITEM DIR COMMANDMENU ATITEMSELECTEDSHADE COMMANDMENUWINDOW) - (PUTWINDOWPROP WINDOW (QUOTE AUTOTESTERBUSY) - T) - (AT.UPDATEAUTOTESTERITEMS (GETWINDOWPROP WINDOW (QUOTE ITEMSPEC)) - WINDOW]) - -(AT.CREATEPRINTSPEC - [LAMBDA (FILEINFO WANTTOSEE NAMESTART) (* scv "13-Jun-85 17:23") - (for HEADING in ATINFOLISTINGWIDTHS by (CDDR HEADING) when (FMEMB HEADING WANTTOSEE) - collect (create ATPRINTSPEC - LABEL _[COND - ((EQ HEADING (QUOTE FILE)) - (SUBSTRING (CDR (FASSOC HEADING FILEINFO)) - NAMESTART)) - (T (CDR (FASSOC HEADING FILEINFO] - WIDTH _(fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS HEADING]) - -(AT.FINDTESTBUCKET - [LAMBDA (WINDOW) (* scv "22-May-85 15:30") - (for TEST in (WINDOWPROP WINDOW (QUOTE AUTOTESTERITEMMAP)) - bind [YPOS _(IPLUS (LASTMOUSEY WINDOW) - (FONTPROP WINDOW (QUOTE DESCENT] - thereis (IGREATERP YPOS (fetch BOTTOM of (fetch (TESTBUCKET ITEMREGION) of TEST]) - -(AT.PROMPTFORINPUT - [LAMBDA (PROMPT EXPRS WINDOW) (* hdj " 1-Sep-84 15:58") - (PROMPTFORWORD PROMPT EXPRS NIL (CAR (GETWINDOWPROP WINDOW (QUOTE PROMPTWINDOW))) - NIL - (QUOTE TTY) - (CHARCODE (CR ESC]) - -(AT.GETALLFILEINFO - [LAMBDA (FILE GENERATOR ATTRIBUTES) (* scv "13-Jun-85 16:15") - - (* *) - - - (for ATTR in ATTRIBUTES collect (if (EQ ATTR (QUOTE FILE)) - then (CONS ATTR FILE) - elseif (EQ ATTR (QUOTE NAME)) - then (CONS ATTR (FILENAMEFIELD FILE (QUOTE NAME))) - elseif (EQ ATTR (QUOTE RESULT)) - then (CONS ATTR (QUOTE ?)) - else (CONS ATTR (\GENERATEFILEINFO GENERATOR ATTR]) - -(AT.GETPRINTDESTINATION - [LAMBDA (KEY) (* scv " 2-Jul-85 10:24") - (if (EQ KEY (QUOTE LEFT)) - then (OPENIMAGESTREAM (QUOTE {LPT})) - else (SELECTQ (MENU (create MENU - ITEMS _(QUOTE (File Printer)) - TITLE _ "Print where?" - MENUCOLUMNS _ 1)) - [File (PROG (FILE) - (SETQ FILE (GetImageFile)) - (RETURN (OPENIMAGESTREAM (CAR FILE) - (CDR FILE] - [Printer (OPENIMAGESTREAM (PACKFILENAME (QUOTE HOST) - (QUOTE LPT) - (QUOTE NAME) - (GetPrinterName] - (SHOULDNT "Bad printer destination"]) - -(AT.\ItemWithTag - [LAMBDA (TAG ITEMS) (* hdj "16-Sep-84 16:16") - - (* * search a menu's items for one with tag TAG) - - - (for ITEM in ITEMS do (if (EQ (CADR ITEM) - TAG) - then (RETURN ITEM]) -) -(DECLARE: EVAL@COMPILE DONTCOPY -(DECLARE: EVAL@COMPILE - -(RPAQQ AT.MARKXPOS 16) - -(CONSTANTS (AT.MARKXPOS 16)) -) - -[DECLARE: EVAL@COMPILE - -(RECORD ATPRINTSPEC (LABEL . WIDTH)) - -(RECORD TESTBUCKET (FILENAME ITEMREGION # SELECTED? COMPLETED? SUCCESSFUL? ITEM)) -] -) - -(ADDTOVAR BackgroundMenuCommands ("AutomatedTester" (AT) - - "Opens an automated tester window; prompts for directory")) - -(RPAQQ BackgroundMenu NIL) -(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA AT) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA AT.PROMPTWPRINT) -) -(PUTPROPS AUTOTEST COPYRIGHT ("XEROX Corporation" 1985)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (9367 16583 (AT 9377 . 9610) (AUTOTESTER 9612 . 14714) (SINGLE-TEST 14716 . 16399) ( -TEST-MESSAGE 16401 . 16581)) (16628 24097 (AT.TESTCOMMAND 16638 . 19449) (AT.ABORTCOMMAND 19451 . -21083) (AT.PAUSECOMMAND 21085 . 21532) (AT.RESUMECOMMAND 21534 . 22689) (AT.DIRECTORYCOMMAND 22691 . -23307) (AT.PRINTCOMMAND 23309 . 23958) (AT.QUITCOMMAND 23960 . 24095)) (24098 38258 ( -AT.COMMANDDISPATCH 24108 . 30527) (AT.SELECT 30529 . 32304) (AT.UPDATEAUTOTESTERITEMS 32306 . 35823) ( -AT.SINGLE-TEST 35825 . 38256)) (38298 53841 (AT.MAKERIGIDWINDOW 38308 . 38784) (AT.CLRPROMPTW 38786 . -38985) (AT.PRINTHEADINGSON 38987 . 40340) (AT.PRINTANDGETREGION 40342 . 41924) (AT.MAKEHEADINGWINDOW -41926 . 42761) (AT.MAKECOUNTERWINDOW 42763 . 43384) (AT.MAKETIMEWINDOW 43386 . 43996) (AT.PROMPTWPRINT - 43998 . 44481) (AT.PROMPTWTERPRI 44483 . 44799) (AT.SELECTFILE 44801 . 45349) (AT.UNSELECTFILE 45351 - . 45816) (AT.CHANGECOMPLETEMARK 45818 . 46341) (AT.SHOW.NUMCOMPLETED 46343 . 47252) (AT.SHOW.NUMFILES - 47254 . 48173) (AT.SHOW.NUMSELECTED 48175 . 49101) (AT.SHOW.NUMSUCCESSFUL 49103 . 50015) ( -AT.SHOW.ENDTIME 50017 . 50974) (AT.SHOW.STARTTIME 50976 . 51941) (AT.SHOW.TESTID 51943 . 52884) ( -AT.SHOW.TESTSUITE 52886 . 53839)) (53871 61709 (AT.HEADINGWREDISPLAYFN 53881 . 54138) ( -AT.REPAINT.COUNTERW 54140 . 54591) (AT.REPAINT.TIMEW 54593 . 55022) (AT.ICONFN 55024 . 55771) ( -AT.BUTTONEVENTFN 55773 . 55913) (AT.CURSORMOVEDFN 55915 . 56280) (AT.CURSOROUTFN 56282 . 56428) ( -AT.REPAINTFN 56430 . 58022) (AT.SCROLLFN 58024 . 58704) (AT.RIGHTBUTTONFN 58706 . 58955) ( -AT.MENU.WHENSELECTEDFN 58957 . 59301) (AT.CLOSEFN 59303 . 60543) (AT.HARDCOPYFN 60545 . 61707)) (61736 - 66330 (AT.FETCHFILENAME 61746 . 61910) (AT.STARTOFNAME 61912 . 62808) (AT.STARTUP 62810 . 63502) ( -AT.CREATEPRINTSPEC 63504 . 64065) (AT.FINDTESTBUCKET 64067 . 64476) (AT.PROMPTFORINPUT 64478 . 64752) -(AT.GETALLFILEINFO 64754 . 65308) (AT.GETPRINTDESTINATION 65310 . 66031) (AT.\ItemWithTag 66033 . -66328))))) -STOP +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Dec-2020 10:55:08" {DSK}larry>ilisp>medley>internal>test>tools>AUTOTEST.;2 79279 changes to%: (FNS AUTOTESTER AT.DIRECTORYCOMMAND) previous date%: "16-Jul-85 15:52:21" {DSK}larry>ilisp>medley>internal>test>tools>AUTOTEST.;1) (* ; " Copyright (c) 1985, 2020 by XEROX Corporation. All rights reserved. ") (PRETTYCOMPRINT AUTOTESTCOMS) (RPAQQ AUTOTESTCOMS [(FILES ATTACHEDWINDOW ICONW) [VARS [ATMENUITEMS '((TEST TEST "Tests the selected files; middle button to also redirect output." ) (ABORT ABORT "Aborts testing of the selected files.") (PAUSE PAUSE "Temporarily pauses in the testing of selected files.") (RESUME RESUME "Resumes PAUSEd testing.") (DIRECTORY DIRECTORY "Does a directory of files in order to create a new set of tests to select." ) (PRINT PRINT "Prints the results of testing of the selected files; middle button to also select printing destination." ) (SUMMARIZE SUMMARIZE "Prints the results of testing of failed tests from the selected files." ) (QUIT QUIT "Quits testing."] (ATNOARGITEMS '(DIRECTORY QUIT)) (ATBUSYOKITEMS '(ABORT PAUSE RESUME QUIT] (INITVARS (ATICONFONT (FONTCREATE 'HELVETICA 8 'MRR)) (DEFAULTAUTOTESTFONT (FONTCREATE 'GACHA 10 'MRR)) (ATTIMEWINDOWFONT (FONTCREATE 'GACHA 8 'MRR)) (ATPROMPTFONT (FONTCREATE 'GACHA 8 'MRR)) (AUTOTESTMENUFONT (FONTCREATE 'HELVETICA 10 'MRR)) (ATBORDERWIDTH 2) [ATINFOLISTINGWIDTHS '(RESULT (Result . 70) NAME (Name . 180) FILE (File . 1800] (ATINFOSHADE 16920) (ATITEMUNSELECTEDSHADE 0) (ATITEMSELECTEDSHADE 43605)) (BITMAPS ATICON ATICONMASK) (CURSORS AT.RIGHTARROWCURSOR) (* * Main autotester fns) (FNS AT AUTOTESTER SINGLE-TEST TEST-MESSAGE) (COMS (* * commands and major subfunctions) (FNS AT.TESTCOMMAND AT.ABORTCOMMAND AT.PAUSECOMMAND AT.RESUMECOMMAND AT.DIRECTORYCOMMAND AT.PRINTCOMMAND AT.QUITCOMMAND) (FNS AT.COMMANDDISPATCH AT.SELECT AT.UPDATEAUTOTESTERITEMS AT.SINGLE-TEST)) (* * lower-level window mungers) (FNS AT.MAKERIGIDWINDOW AT.CLRPROMPTW AT.PRINTHEADINGSON AT.PRINTANDGETREGION AT.MAKEHEADINGWINDOW AT.MAKECOUNTERWINDOW AT.MAKETIMEWINDOW AT.PROMPTWPRINT AT.PROMPTWTERPRI AT.SELECTFILE AT.UNSELECTFILE AT.CHANGECOMPLETEMARK AT.SHOW.NUMCOMPLETED AT.SHOW.NUMFILES AT.SHOW.NUMSELECTED AT.SHOW.NUMSUCCESSFUL AT.SHOW.ENDTIME AT.SHOW.STARTTIME AT.SHOW.TESTID AT.SHOW.TESTSUITE) (* * window functions) (FNS AT.HEADINGWREDISPLAYFN AT.REPAINT.COUNTERW AT.REPAINT.TIMEW AT.ICONFN AT.BUTTONEVENTFN AT.CURSORMOVEDFN AT.CURSOROUTFN AT.REPAINTFN AT.SCROLLFN AT.RIGHTBUTTONFN AT.MENU.WHENSELECTEDFN AT.CLOSEFN AT.HARDCOPYFN) (* * odds and ends) (FNS AT.FETCHFILENAME AT.STARTOFNAME AT.STARTUP AT.CREATEPRINTSPEC AT.FINDTESTBUCKET AT.PROMPTFORINPUT AT.GETALLFILEINFO AT.GETPRINTDESTINATION AT.\ItemWithTag) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (AT.MARKXPOS 16)) (RECORDS ATPRINTSPEC TESTBUCKET)) (ADDVARS (BackgroundMenuCommands ("AutomatedTester" (AT) "Opens an automated tester window; prompts for directory" ))) (VARS (BackgroundMenu)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA AT) (NLAML) (LAMA AT.PROMPTWPRINT]) (FILESLOAD ATTACHEDWINDOW ICONW) (RPAQQ ATMENUITEMS ((TEST TEST "Tests the selected files; middle button to also redirect output.") (ABORT ABORT "Aborts testing of the selected files.") (PAUSE PAUSE "Temporarily pauses in the testing of selected files.") (RESUME RESUME "Resumes PAUSEd testing.") (DIRECTORY DIRECTORY "Does a directory of files in order to create a new set of tests to select.") (PRINT PRINT "Prints the results of testing of the selected files; middle button to also select printing destination." ) (SUMMARIZE SUMMARIZE "Prints the results of testing of failed tests from the selected files." ) (QUIT QUIT "Quits testing."))) (RPAQQ ATNOARGITEMS (DIRECTORY QUIT)) (RPAQQ ATBUSYOKITEMS (ABORT PAUSE RESUME QUIT)) (RPAQ? ATICONFONT (FONTCREATE 'HELVETICA 8 'MRR)) (RPAQ? DEFAULTAUTOTESTFONT (FONTCREATE 'GACHA 10 'MRR)) (RPAQ? ATTIMEWINDOWFONT (FONTCREATE 'GACHA 8 'MRR)) (RPAQ? ATPROMPTFONT (FONTCREATE 'GACHA 8 'MRR)) (RPAQ? AUTOTESTMENUFONT (FONTCREATE 'HELVETICA 10 'MRR)) (RPAQ? ATBORDERWIDTH 2) (RPAQ? ATINFOLISTINGWIDTHS '(RESULT (Result . 70) NAME (Name . 180) FILE (File . 1800))) (RPAQ? ATINFOSHADE 16920) (RPAQ? ATITEMUNSELECTEDSHADE 0) (RPAQ? ATITEMSELECTEDSHADE 43605) (RPAQQ ATICON #*(80 80)OOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@COAH@@@@AOOOOOOON@@@GOIH@@@@AOOOOOOON@@@NAMH@@@@AOOOOOOON@@@L@MH@@@@AOOOOOOON@@@L@MH@@@@AOOOOOOON@@@@@MH@@@@AOOOOOOON@@@@@MH@@@@AOOOOOOON@@@@AMHH@HFAOOOOOOONAH@@OIHLAHCAOOOOOOON@L@@OAHFC@AIOOOOOOON@F@@LAHCF@@MOOOOOOON@C@@LAHALGOOOOOOOOOOOOH@LAHALGOOOOOOOOOOOOH@LAHCF@@MOOOOOOON@C@@LAHFC@AIOOOOOOON@F@@LAHLAHCAOOOOOOON@L@@LAHH@HFAOOOOOOONAH@@@AH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@@LAH@@@@AOOOOOOON@@@@LAH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@@@AH@@@@AOOOOOOON@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOO ) (RPAQQ ATICONMASK #*(80 80)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO ) (RPAQ AT.RIGHTARROWCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@F@@@GH@@GN@@GOHOOONOOOOOOON@GOH@GN@@GH@@F@@@@@@@@@@@@@@ ) (QUOTE NIL) 7 9)) (* * Main autotester fns) (DEFINEQ (AT [NLAMBDA DIR (* scv "23-May-85 11:28") (AUTOTESTER (OR (CAR (NLAMBDA.ARGS DIR)) (PROMPTFORWORD "Test directory pattern?" NIL NIL PROMPTWINDOW]) (AUTOTESTER [LAMBDA (FILESPEC) (* ; "Edited 17-Dec-2020 16:54 by larry") (* scv "15-Jul-85 15:36") (PROG ((PROMPTWHEIGHT 3) AUTOTESTWINDOW COMMANDMENUWINDOW COMMANDMENU DIRSTART HEADINGW COUNTERW TIMEW TTYDS) (COND ((NULL FILESPEC) (RETURN))) (SETQ FILESPEC (DIRECTORY.FILL.PATTERN FILESPEC "DFASL" "")) (SETQ COMMANDMENU (create MENU MENUFONT _ AUTOTESTMENUFONT ITEMS _ ATMENUITEMS MENUROWS _ 1 CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION AT.MENU.WHENSELECTEDFN))) (SETQ AUTOTESTWINDOW (CREATEW (GETREGION (WIDTHIFWINDOW (fetch IMAGEWIDTH of COMMANDMENU ) (fetch MENUOUTLINESIZE of COMMANDMENU )) (HEIGHTIFWINDOW (ITIMES 4 (FONTPROP DEFAULTAUTOTESTFONT 'HEIGHT)) NIL ATBORDERWIDTH)) NIL ATBORDERWIDTH)) (SETQ HEADINGW (AT.MAKEHEADINGWINDOW (GETWINDOWPROP AUTOTESTWINDOW 'WIDTH) DEFAULTAUTOTESTFONT ATBORDERWIDTH "Automated Tester Window")) (SETQ COUNTERW (AT.MAKECOUNTERWINDOW (HEIGHTIFWINDOW (FONTPROP DEFAULTAUTOTESTFONT 'HEIGHT)) (WINDOWPROP HEADINGW 'WIDTH) AUTOTESTWINDOW)) (SETQ TIMEW (AT.MAKETIMEWINDOW (HEIGHTIFWINDOW (FONTPROP ATTIMEWINDOWFONT 'HEIGHT)) (WINDOWPROP HEADINGW 'WIDTH) AUTOTESTWINDOW)) (PUTWINDOWPROP AUTOTESTWINDOW 'HEADINGWINDOW HEADINGW) (ATTACHWINDOW HEADINGW AUTOTESTWINDOW 'TOP) (PUTWINDOWPROP AUTOTESTWINDOW 'COUNTERWINDOW COUNTERW) (ATTACHWINDOW COUNTERW HEADINGW 'TOP) (PUTWINDOWPROP AUTOTESTWINDOW 'TIMEWINDOW TIMEW) (ATTACHWINDOW TIMEW COUNTERW 'TOP) (SETQ COMMANDMENUWINDOW (ATTACHMENU COMMANDMENU AUTOTESTWINDOW 'TOP)) (PUTWINDOWPROP AUTOTESTWINDOW 'SCROLLFN (FUNCTION AT.SCROLLFN)) (AT.MAKERIGIDWINDOW (GETPROMPTWINDOW AUTOTESTWINDOW PROMPTWHEIGHT ATPROMPTFONT)) (DSPFONT DEFAULTAUTOTESTFONT AUTOTESTWINDOW) (PUTWINDOWPROP AUTOTESTWINDOW 'ICONFN (FUNCTION AT.ICONFN)) (PUTWINDOWPROP AUTOTESTWINDOW 'ICONTITLE FILESPEC) (PUTWINDOWPROP AUTOTESTWINDOW 'NUMCOMPLETED 0) (PUTWINDOWPROP AUTOTESTWINDOW 'NUMSUCCESSFUL 0) (PUTWINDOWPROP AUTOTESTWINDOW 'ORIGX (DSPXPOSITION NIL AUTOTESTWINDOW)) (PUTWINDOWPROP AUTOTESTWINDOW 'ORIGY (DSPYPOSITION NIL AUTOTESTWINDOW)) (PUTWINDOWPROP AUTOTESTWINDOW 'DIRWIDTH (GETWINDOWPROP AUTOTESTWINDOW 'WIDTH)) (PUTWINDOWPROP AUTOTESTWINDOW 'BUTTONEVENTFN (FUNCTION AT.BUTTONEVENTFN)) (PUTWINDOWPROP AUTOTESTWINDOW 'RIGHTBUTTONFN (FUNCTION AT.RIGHTBUTTONFN)) (PUTWINDOWPROP AUTOTESTWINDOW 'REPAINTFN (FUNCTION AT.REPAINTFN)) (PUTWINDOWPROP AUTOTESTWINDOW 'CURSORMOVEDFN (FUNCTION AT.CURSORMOVEDFN)) (PUTWINDOWPROP AUTOTESTWINDOW 'CURSOROUTFN (FUNCTION AT.CURSOROUTFN)) (WINDOWADDPROP AUTOTESTWINDOW 'RESHAPEFN (FUNCTION RESHAPEBYREPAINTFN)) (WINDOWADDPROP AUTOTESTWINDOW 'SHRINKFN (FUNCTION AT.CLOSEFN) T) (WINDOWADDPROP AUTOTESTWINDOW 'CLOSEFN (FUNCTION AT.CLOSEFN) T) (PUTWINDOWPROP AUTOTESTWINDOW 'ITEMSPEC FILESPEC) (PUTWINDOWPROP AUTOTESTWINDOW 'HARDCOPYFN 'AT.HARDCOPYFN) (WINDOWPROP COMMANDMENUWINDOW 'HARDCOPYFN 'AT.HARDCOPYFN) (WINDOWPROP HEADINGW 'HARDCOPYFN 'AT.HARDCOPYFN) (WINDOWPROP COUNTERW 'HARDCOPYFN 'AT.HARDCOPYFN) (WINDOWPROP TIMEW 'HARDCOPYFN 'AT.HARDCOPYFN) (WINDOWPROP (GETPROMPTWINDOW AUTOTESTWINDOW) 'HARDCOPYFN 'AT.HARDCOPYFN) (SETQ TTYDS (WFROMDS (TTYDISPLAYSTREAM))) (PUTWINDOWPROP AUTOTESTWINDOW 'ATDISPLAYSTREAM TTYDS) (WINDOWPROP TTYDS 'PAGEFULLFN 'NILL) (WINDOWPROP TTYDS 'AUTOTESTER AUTOTESTWINDOW) (ADD.PROCESS (LIST (FUNCTION AT.STARTUP) AUTOTESTWINDOW COMMANDMENU COMMANDMENUWINDOW) 'NAME 'AT-Update) (RETURN AUTOTESTWINDOW]) (SINGLE-TEST [LAMBDA (IDENTIFIER EXPRESSION PREDICATE TIMEOUT) (* scv "12-Jul-85 16:22") (PROG (MAIN PROC RESULT TESTEND) (SETQ MAIN (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM)) 'AUTOTESTER)) (WINDOWPROP MAIN 'TESTRESULT NIL) (PUTWINDOWPROP MAIN 'TESTSTART NIL) (PUTWINDOWPROP MAIN 'TESTEND NIL) [SETQ PROC (ADD.PROCESS (LIST 'AT.SINGLE-TEST (KWOTE IDENTIFIER) (KWOTE EXPRESSION) (KWOTE PREDICATE) (KWOTE TIMEOUT) (KWOTE (TTYDISPLAYSTREAM)) (KWOTE (OUTPUT))) 'NAME (CONCAT 'SINGLE-TEST- IDENTIFIER) 'WINDOW (WFROMDS (TTYDISPLAYSTREAM] (WHILE (AND [NULL (SETQ RESULT (WINDOWPROP MAIN 'TESTRESULT] (OR (NULL TIMEOUT) [NULL (SETQ TESTEND (WINDOWPROP MAIN 'TESTEND] (LESSP (CLOCK 0) TESTEND)) (PROCESSP PROC)) DO (DISMISS 50)) (PUTWINDOWPROP MAIN 'TESTID NIL) (AT.SHOW.TESTID MAIN) (PUTWINDOWPROP MAIN 'STARTTIME NIL) (AT.SHOW.STARTTIME MAIN) (PUTWINDOWPROP MAIN 'ENDTIME NIL) (AT.SHOW.ENDTIME MAIN) (IF (NULL RESULT) THEN (TEST-MESSAGE IDENTIFIER "timed out, timeout" TIMEOUT) (DEL.PROCESS PROC) (RETURN NIL) ELSE (RETURN (CAR RESULT]) (TEST-MESSAGE [LAMBDA (IDENTIFIER TEXT INFO) (* scv " 3-Jul-85 12:07") (printout NIL "===> Test " IDENTIFIER ": " TEXT ": " INFO T]) ) (* * commands and major subfunctions) (DEFINEQ (AT.TESTCOMMAND [LAMBDA (FILEENTRY KEY WINDOW STDOUT) (* scv "12-Jul-85 14:21") (PROG (FILENAME NUM ITEMMAP RESULT) (BLOCK) (OUTPUT STDOUT) [WINDOWPROP WINDOW 'TESTSUITE (fetch (ATPRINTSPEC LABEL) of (CADR (fetch (TESTBUCKET ITEM) of FILEENTRY ] (AT.SHOW.TESTSUITE WINDOW) (SETQ FILENAME (fetch (TESTBUCKET FILENAME) of FILEENTRY)) (SETQ NUM (fetch (TESTBUCKET %#) of FILEENTRY)) (SETQ ITEMMAP (WINDOWPROP WINDOW 'AUTOTESTERITEMMAP)) (LISPXEVAL (LIST 'LOAD (LIST 'QUOTE FILENAME))) [SETQ RESULT (LISPXEVAL (LIST (FILENAMEFIELD FILENAME 'NAME) (LIST 'QUOTE (PACKFILENAME 'NAME "" 'EXTENSION "" 'VERSION "" 'BODY FILENAME] (replace (TESTBUCKET COMPLETED?) of FILEENTRY with T) [WINDOWPROP WINDOW 'NUMCOMPLETED (ADD1 (WINDOWPROP WINDOW 'NUMCOMPLETED] (replace (TESTBUCKET SUCCESSFUL?) of FILEENTRY with RESULT) [if RESULT then (WINDOWPROP WINDOW 'NUMSUCCESSFUL (ADD1 (WINDOWPROP WINDOW 'NUMSUCCESSFUL] (AT.SHOW.NUMCOMPLETED WINDOW) (AT.SHOW.NUMSUCCESSFUL WINDOW) [replace (TESTBUCKET ITEM) of FILEENTRY with (CONS [create ATPRINTSPEC LABEL _ (if RESULT then 'pass else 'FAIL) WIDTH _ (fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS 'RESULT] (CDR (fetch (TESTBUCKET ITEM) of FILEENTRY] (SETQ ITEMMAP (for I in ITEMMAP collect (if (EQP NUM (fetch (TESTBUCKET %#) of I)) then FILEENTRY else I))) (WINDOWPROP WINDOW 'AUTOTESTERITEMMAP ITEMMAP) (UNDOLISPX1 (LISPXFIND LISPXHISTORY (LIST (CADR LISPXHISTORY)) 'ENTRY NIL)) (UNDOLISPX1 (LISPXFIND LISPXHISTORY (LIST (SUB1 (CADR LISPXHISTORY))) 'ENTRY NIL)) (REDISPLAYW WINDOW (fetch (TESTBUCKET ITEMREGION) of FILEENTRY)) (WINDOWPROP WINDOW 'TESTSUITE NIL) (AT.SHOW.TESTSUITE WINDOW) (OUTPUT T]) (AT.ABORTCOMMAND [LAMBDA (KEY WINDOW) (* scv "12-Jul-85 16:19") (PROG (PAUSED? PAUSE) (SETQ PAUSED? (GETWINDOWPROP WINDOW 'PAUSESTART)) (if (NOT PAUSED?) then (SETQ PAUSE (CLOCK 0)) (PUTWINDOWPROP WINDOW 'PAUSESTART PAUSE)) (if (MOUSECONFIRM "Are you sure? " "Click left button to ABORT tests, right button to RESUME tests." (GETPROMPTWINDOW (MAINWINDOW WINDOW T))) then [PROG (PROC) (SETQ PROC (GETWINDOWPROP WINDOW 'TESTPROCESS)) (if PROC then (DEL.PROCESS PROC) (PUTWINDOWPROP WINDOW 'PAUSESTART NIL) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests in process.") (if (NOT PAUSED?) then (PUTWINDOWPROP WINDOW 'PAUSESTART NIL] else (if (NOT PAUSED?) then (PUTWINDOWPROP WINDOW 'PAUSESTART NIL) (if (GETWINDOWPROP WINDOW 'TESTEND) then (PUTWINDOWPROP WINDOW 'ENDTIME (PLUS (GETWINDOWPROP WINDOW 'ENDTIME) (IQUOTIENT (DIFFERENCE (CLOCK 0) PAUSE) 1000))) (AT.SHOW.ENDTIME (MAINWINDOW WINDOW T)) (PUTWINDOWPROP WINDOW 'TESTEND (PLUS (GETWINDOWPROP WINDOW 'TESTEND) (DIFFERENCE (CLOCK 0) PAUSE]) (AT.PAUSECOMMAND [LAMBDA (KEY WINDOW) (* scv " 2-Jul-85 15:29") (PROG (PROC) (SETQ PROC (GETWINDOWPROP WINDOW 'TESTPROCESS)) (if PROC then (SUSPEND.PROCESS PROC) (PUTWINDOWPROP WINDOW 'PAUSESTART (CLOCK 0)) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests in process."]) (AT.RESUMECOMMAND [LAMBDA (KEY WINDOW) (* scv "12-Jul-85 16:19") (PROG (PROC PAUSE) (SETQ PROC (GETWINDOWPROP WINDOW 'TESTPROCESS)) (if PROC then (if (SETQ PAUSE (GETWINDOWPROP WINDOW 'PAUSESTART)) then (PUTWINDOWPROP WINDOW 'PAUSESTART NIL) [if (GETWINDOWPROP WINDOW 'TESTEND) then (PUTWINDOWPROP WINDOW 'ENDTIME (PLUS (GETWINDOWPROP WINDOW 'ENDTIME) (IQUOTIENT (DIFFERENCE (CLOCK 0) PAUSE) 1000))) (AT.SHOW.ENDTIME (MAINWINDOW WINDOW T)) (PUTWINDOWPROP WINDOW 'TESTEND (PLUS (GETWINDOWPROP WINDOW 'TESTEND) (DIFFERENCE (CLOCK 0) PAUSE] (WAKE.PROCESS PROC) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests paused.")) else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No tests in process."]) (AT.DIRECTORYCOMMAND [LAMBDA (KEY WINDOW) (* ; "Edited 17-Dec-2020 17:08 by larry") (* scv "20-Jun-85 12:58") (PROG (FILESPEC) (AT.CLRPROMPTW WINDOW) (if (NULL (SETQ FILESPEC (AT.PROMPTFORINPUT "New test directory pattern? " (GETWINDOWPROP WINDOW 'ITEMSPEC) WINDOW))) then (RETURN)) (PUTWINDOWPROP WINDOW 'ICONTITLE FILESPEC) (PUTWINDOWPROP WINDOW 'ITEMSPEC (DIRECTORY.FILL.PATTERN FILESPEC "DFASL" "")) (RETURN T]) (AT.PRINTCOMMAND [LAMBDA (FILEENTRY KEY WINDOW IMAGESTREAM) (* scv " 2-Jul-85 10:36") (PROG (XPOS FONTWIDTH) (SETQ FONTWIDTH (CHARWIDTH (CHCON1 "M") (DSPFONT NIL IMAGESTREAM))) (SETQ XPOS (DSPLEFTMARGIN NIL IMAGESTREAM)) (for I in (fetch (TESTBUCKET ITEM) of FILEENTRY) do (printout IMAGESTREAM (fetch (ATPRINTSPEC LABEL) of I)) (DSPXPOSITION (SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of I) FONTWIDTH))) IMAGESTREAM)) (TERPRI IMAGESTREAM]) (AT.QUITCOMMAND [LAMBDA (KEY WINDOW) (* scv "31-May-85 12:49") (CLOSEW WINDOW]) ) (DEFINEQ (AT.COMMANDDISPATCH [LAMBDA (ITEM MENU KEY) (* scv " 3-Jul-85 11:53") (PROG (WINDOW ATUPDATE? FILELIST ITEMMAP NUMCOMPLETED NUMSUCCESSFUL FILE XPOS STDOUT) (SETQ WINDOW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW)) (COND ((FMEMB (CADR ITEM) ATBUSYOKITEMS)) ((GETWINDOWPROP WINDOW 'AUTOTESTERBUSY) (AT.PROMPTWPRINT WINDOW "The autotester is busy.") (RETURN))) (COND ((EQUAL (CADR ITEM) '"") (RETURN))) (SETQ ITEMMAP (WINDOWPROP WINDOW 'AUTOTESTERITEMMAP)) (OR (FMEMB (CADR ITEM) ATNOARGITEMS) [SETQ FILELIST (for INDEX in (WINDOWPROP WINDOW 'CURRENTTESTNUMBERS) collect (CAR (NTH ITEMMAP INDEX] (PROGN (AT.PROMPTWPRINT WINDOW "No tests are selected") (RETURN))) (RESETLST (RESETSAVE NIL (LIST 'SHADEITEM ITEM MENU ATITEMUNSELECTEDSHADE)) [RESETSAVE NIL (LIST [FUNCTION (LAMBDA (W P) (PUTWINDOWPROP W 'AUTOTESTERBUSY P] WINDOW (GETWINDOWPROP WINDOW 'AUTOTESTERBUSY] (PUTWINDOWPROP WINDOW 'AUTOTESTERBUSY T) (SHADEITEM ITEM MENU ATITEMSELECTEDSHADE) [SELECTQ (CADR ITEM) (TEST (RESETLST (RESETSAVE NIL (LIST 'PUTWINDOWPROP WINDOW 'TESTPROCESS NIL)) [RESETSAVE NIL (LIST 'SETTOPVAL 'HELPFLAG (GETTOPVAL 'HELPFLAG] (RESETSAVE NIL (LIST 'SET 'HELPFLAG HELPFLAG)) (PUTWINDOWPROP WINDOW 'TESTPROCESS (THIS.PROCESS)) (SETTOPVAL 'HELPFLAG NIL) (SETQ HELPFLAG NIL) [SETQ STDOUT (if (EQ KEY 'LEFT) then T else (OPENFILE (AT.PROMPTFORINPUT "Name of file to direct output to? " "" WINDOW) 'OUTPUT] (SETQ NUMCOMPLETED (WINDOWPROP WINDOW 'NUMCOMPLETED)) (SETQ NUMSUCCESSFUL (WINDOWPROP WINDOW 'NUMSUCCESSFUL)) [for FILEENTRY in ITEMMAP do (if (AND (FMEMB (fetch (TESTBUCKET %#) of FILEENTRY ) (WINDOWPROP WINDOW 'CURRENTTESTNUMBERS)) (fetch (TESTBUCKET COMPLETED?) of FILEENTRY )) then (SETQ NUMCOMPLETED (SUB1 NUMCOMPLETED)) (replace (TESTBUCKET COMPLETED?) of FILEENTRY with NIL) (if (fetch (TESTBUCKET SUCCESSFUL?) of FILEENTRY) then (SETQ NUMSUCCESSFUL (SUB1 NUMSUCCESSFUL) ) (replace (TESTBUCKET SUCCESSFUL?) of FILEENTRY with NIL] (WINDOWPROP WINDOW 'NUMCOMPLETED NUMCOMPLETED) (WINDOWPROP WINDOW 'NUMSUCCESSFUL NUMSUCCESSFUL) (AT.SHOW.NUMCOMPLETED WINDOW) (AT.SHOW.NUMSUCCESSFUL WINDOW) (WINDOWPROP WINDOW 'AUTOTESTERITEMMAP ITEMMAP) (REDISPLAYW WINDOW) (TTYDISPLAYSTREAM (WINDOWPROP WINDOW 'ATDISPLAYSTREAM)) (CLEARW (WINDOWPROP WINDOW 'ATDISPLAYSTREAM)) (for FILEENTRY in FILELIST do (AT.TESTCOMMAND FILEENTRY KEY WINDOW STDOUT)) (if (NEQ STDOUT T) then (CLOSEF STDOUT)))) (ABORT (AT.ABORTCOMMAND KEY WINDOW)) (PAUSE (AT.PAUSECOMMAND KEY WINDOW)) (RESUME (AT.RESUMECOMMAND KEY WINDOW)) (DIRECTORY (SETQ ATUPDATE? (AT.DIRECTORYCOMMAND KEY WINDOW))) (PRINT (SETQ FILE (AT.GETPRINTDESTINATION KEY)) (printout FILE "Testing results for " (WINDOWPROP WINDOW 'ITEMSPEC) ":" T T) (SETQ XPOS (DSPLEFTMARGIN NIL FILE)) (for I on ATINFOLISTINGWIDTHS by (CDDR I) do (printout FILE (fetch (ATPRINTSPEC LABEL) of (CADR I))) (DSPXPOSITION [SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of (CADR I)) (CHARWIDTH (CHCON1 "M") (DSPFONT NIL FILE ] FILE)) (TERPRI FILE) (for FILEENTRY in FILELIST do (AT.PRINTCOMMAND FILEENTRY KEY WINDOW FILE)) (CLOSEF FILE)) (SUMMARIZE (SETQ FILE (AT.GETPRINTDESTINATION KEY)) (printout FILE "Testing summary for " (WINDOWPROP WINDOW 'ITEMSPEC) ":" T T) (SETQ XPOS (DSPLEFTMARGIN NIL FILE)) (for I on ATINFOLISTINGWIDTHS by (CDDR I) do (printout FILE (fetch (ATPRINTSPEC LABEL) of (CADR I))) (DSPXPOSITION [SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of (CADR I)) (CHARWIDTH (CHCON1 "M") (DSPFONT NIL FILE] FILE)) (TERPRI FILE) (for FILEENTRY in FILELIST do (if (NULL (fetch (TESTBUCKET SUCCESSFUL?) of FILEENTRY)) then (AT.PRINTCOMMAND FILEENTRY KEY WINDOW FILE))) (CLOSEF FILE)) (QUIT (AT.QUITCOMMAND KEY WINDOW)) (LET ((FN (CADR ITEM))) (if (EQ (CAR FN) 'FUNCTION) then (APPLY* (CADR FN) FILELIST KEY WINDOW) else (SHOULDNT] (COND (ATUPDATE? (AT.UPDATEAUTOTESTERITEMS (WINDOWPROP WINDOW 'ITEMSPEC) WINDOW))))]) (AT.SELECT [LAMBDA (WINDOW) (* scv "22-May-85 15:32") (PROG (AUTOTESTERITEMMAP TEST SETSEL ADDSEL EXTEND CURRENT#S TEST# FIRST# LAST#) (OR (SETQ SETSEL (MOUSESTATE LEFT)) (SETQ ADDSEL (LASTMOUSESTATE MIDDLE)) (SETQ EXTEND (LASTMOUSESTATE RIGHT)) (RETURN)) (SETQ AUTOTESTERITEMMAP (WINDOWPROP WINDOW 'AUTOTESTERITEMMAP)) (SETQ TEST (AT.FINDTESTBUCKET WINDOW)) (COND ((NULL TEST) (RETURN))) [COND (SETSEL (for TEST# in (GETWINDOWUSERPROP WINDOW 'CURRENTTESTNUMBERS) do (AT.UNSELECTFILE (CAR (FNTH AUTOTESTERITEMMAP TEST#)) WINDOW)) (AT.SELECTFILE TEST WINDOW)) (ADDSEL (if (fetch (TESTBUCKET SELECTED?) of TEST) then (AT.UNSELECTFILE TEST WINDOW) else (AT.SELECTFILE TEST WINDOW))) (EXTEND (* have to find all the messages  between TEST and the one selected *) (COND ([SETQ CURRENT#S (SORT (WINDOWPROP WINDOW 'CURRENTTESTNUMBERS] (SETQ TEST# (fetch (TESTBUCKET %#) of TEST)) [COND [(ILESSP TEST# (CAR CURRENT#S)) (* before *) (SETQ FIRST# TEST#) (SETQ LAST# (SUB1 (CAR CURRENT#S] (T (SETQ LAST# TEST#) (* after *) (SETQ FIRST# (ADD1 (CAR (LAST CURRENT#S] (for I from FIRST# to LAST# do (AT.SELECTFILE (CAR (NTH AUTOTESTERITEMMAP I)) WINDOW] (AT.SHOW.NUMSELECTED WINDOW]) (AT.UPDATEAUTOTESTERITEMS [LAMBDA (ITEMSPEC WINDOW) (* scv "12-Jul-85 14:07") (PROG ((INFOWANTED '(RESULT NAME FILE)) HEADINGWINDOW FILEGENERATOR FILENAME FILEINFO MAXWIDTH AUTOTESTERITEMMAP) [SETQ FILEGENERATOR (\GENERATEFILES ITEMSPEC '(NAME) '(SORT RESETLST] (SETQ HEADINGWINDOW (GETWINDOWPROP WINDOW 'HEADINGWINDOW)) (WINDOWPROP HEADINGWINDOW 'TITLE "Auto Tester") (CLEARW (WINDOWPROP WINDOW 'COUNTERWINDOW)) (PUTWINDOWPROP WINDOW 'EXTENT NIL) (* set EXTENT to NIL while updating) (PUTWINDOWPROP WINDOW 'INFOGOTTEN INFOWANTED) (PUTWINDOWPROP WINDOW 'DIRWIDTH (SETQ MAXWIDTH (AT.PRINTHEADINGSON HEADINGWINDOW INFOWANTED))) (DSPRIGHTMARGIN 32767 WINDOW) (CLEARW WINDOW) [SETQ AUTOTESTERITEMMAP (while (SETQ FILENAME (\GENERATENEXTFILE FILEGENERATOR)) as ITEMCOUNT from 1 bind ITEM bind STARTOFNAME collect (if (LISTP FILENAME) then (SETQ FILENAME (CONCATCODES FILENAME))) (SETQ FILEINFO (AT.GETALLFILEINFO FILENAME FILEGENERATOR INFOWANTED)) (create TESTBUCKET FILENAME _ FILENAME %# _ ITEMCOUNT ITEM _ [SETQ ITEM (AT.CREATEPRINTSPEC FILEINFO INFOWANTED (OR STARTOFNAME (SETQ STARTOFNAME (AT.STARTOFNAME FILENAME ITEMSPEC] ITEMREGION _ (AT.PRINTANDGETREGION ITEM WINDOW AT.MARKXPOS 10) SELECTED? _ NIL COMPLETED? _ NIL SUCCESSFUL? _ '?] (PUTWINDOWPROP WINDOW 'AUTOTESTERITEMMAP AUTOTESTERITEMMAP) (PUTWINDOWPROP WINDOW 'EXTENT (if AUTOTESTERITEMMAP then [create REGION LEFT _ 0 BOTTOM _ [fetch (REGION BOTTOM) of (fetch (TESTBUCKET ITEMREGION) of (CAR (LAST AUTOTESTERITEMMAP ] WIDTH _ MAXWIDTH HEIGHT _ (IDIFFERENCE (fetch (REGION PTOP) of (fetch (TESTBUCKET ITEMREGION) of (CAR AUTOTESTERITEMMAP ))) (fetch (REGION BOTTOM) of (fetch (TESTBUCKET ITEMREGION) of (CAR (LAST AUTOTESTERITEMMAP ] else (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "No files in group " ITEMSPEC) NIL)) (PUTWINDOWPROP HEADINGWINDOW 'TITLE (CONCAT (WINDOWPROP WINDOW 'ITEMSPEC) " tester")) (PUTWINDOWPROP WINDOW 'CURRENTTESTNUMBERS NIL) (PUTWINDOWPROP WINDOW 'CURRENTITEM NIL) (PUTWINDOWPROP WINDOW 'NUMCOMPLETED 0) (PUTWINDOWPROP WINDOW 'NUMSUCCESSFUL 0) (AT.SHOW.NUMFILES WINDOW) (AT.SHOW.NUMSELECTED WINDOW) (AT.SHOW.NUMCOMPLETED WINDOW) (AT.SHOW.NUMSUCCESSFUL WINDOW) (AT.SHOW.TESTSUITE WINDOW) (AT.SHOW.TESTID WINDOW) (AT.SHOW.STARTTIME WINDOW) (AT.SHOW.ENDTIME WINDOW]) (AT.SINGLE-TEST [LAMBDA (IDENTIFIER EXPRESSION PREDICATE TIMEOUT TTYDS STDOUT) (* scv "12-Jul-85 16:08") (PROG (RESULT MAIN START) (TTYDISPLAYSTREAM TTYDS) (OUTPUT STDOUT) (SETQ MAIN (WINDOWPROP (WFROMDS TTYDS) 'AUTOTESTER)) (PUTWINDOWPROP MAIN 'TESTID IDENTIFIER) (AT.SHOW.TESTID MAIN) (PUTWINDOWPROP MAIN 'STARTTIME (IDATE)) (AT.SHOW.STARTTIME MAIN) (IF TIMEOUT THEN (* The following assumes that the date format used by IDATE and GDATE is in  seconds.) (PUTWINDOWPROP MAIN 'ENDTIME (PLUS (IDATE) (QUOTIENT TIMEOUT 1000))) (AT.SHOW.ENDTIME MAIN)) (BLOCK) (SETQ START (CLOCK 0)) (PUTWINDOWPROP MAIN 'TESTSTART START) (PUTWINDOWPROP MAIN 'TESTEND (if TIMEOUT then (PLUS START TIMEOUT) else -1)) (SETQ RESULT (ERRORSET EXPRESSION T)) (PUTWINDOWPROP MAIN 'TESTSTART NIL) (PUTWINDOWPROP MAIN 'TESTEND NIL) (BLOCK) (if (NULL RESULT) then (TEST-MESSAGE IDENTIFIER "got an error in expression" EXPRESSION) (PUTWINDOWPROP MAIN 'TESTRESULT '(NIL)) elseif (EQ (CAR RESULT) 'NOBIND) then (TEST-MESSAGE IDENTIFIER "returned NOBIND in expression" EXPRESSION) (PUTWINDOWPROP MAIN 'TESTRESULT '(NIL)) else [SETQ RESULT (ERSETQ (APPLY* PREDICATE (CAR RESULT] (BLOCK) (if (NULL RESULT) then (TEST-MESSAGE IDENTIFIER "got an error in predicate" PREDICATE) (PUTWINDOWPROP MAIN 'TESTRESULT '(NIL)) elseif (EQ (CAR RESULT) 'NOBIND) then (TEST-MESSAGE IDENTIFIER "returned NOBIND in predicate" PREDICATE) (PUTWINDOWPROP MAIN 'TESTRESULT '(NIL)) else (PUTWINDOWPROP MAIN 'TESTRESULT RESULT]) ) (* * lower-level window mungers) (DEFINEQ (AT.MAKERIGIDWINDOW [LAMBDA (WINDOW) (* lmm "14-Sep-84 16:22") (* * make the argument window immutable w/r/to attachedwindow package) (PROG [(HEIGHT (fetch (REGION HEIGHT) of (GETWINDOWPROP WINDOW 'REGION] (PUTWINDOWPROP WINDOW 'MINSIZE (CONS 0 HEIGHT)) (PUTWINDOWPROP WINDOW 'MAXSIZE (CONS SCREENWIDTH HEIGHT]) (AT.CLRPROMPTW [LAMBDA (MAINWINDOW) (* Jellinek " 6-May-84 16:48") (CLEARW (CAR (GETWINDOWPROP MAINWINDOW 'PROMPTWINDOW]) (AT.PRINTHEADINGSON [LAMBDA (WINDOW HEADINGS) (* scv " 1-Jul-85 10:35") (PROG ((totalwidth 0) BOTTOM) (DSPRIGHTMARGIN 32000 WINDOW) (DSPTEXTURE BLACKSHADE WINDOW) (DSPOPERATION 'INVERT WINDOW) (DSPFILL NIL BLACKSHADE 'REPLACE WINDOW) (for HEADING in ATINFOLISTINGWIDTHS by (CDDR HEADING) bind word width (pos _ AT.MARKXPOS) when (FMEMB HEADING HEADINGS) do (SETQ word (fetch (ATPRINTSPEC LABEL) of (LISTGET ATINFOLISTINGWIDTHS HEADING))) (SETQ width (ITIMES (fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS HEADING)) (CHARWIDTH (CHCON1 "M") DEFAULTAUTOTESTFONT))) (SETQ totalwidth (IPLUS totalwidth width)) (DSPXPOSITION pos WINDOW) (PRIN3 word WINDOW) (add pos width)) (PUTWINDOWPROP WINDOW 'EXTENT (create REGION LEFT _ 0 BOTTOM _ [SETQ BOTTOM (IPLUS (DSPYPOSITION NIL WINDOW) (FONTPROP WINDOW 'ASCENT] WIDTH _ totalwidth HEIGHT _ (IDIFFERENCE (GETWINDOWPROP WINDOW 'HEIGHT) BOTTOM))) (RETURN totalwidth]) (AT.PRINTANDGETREGION [LAMBDA (PRINTSPEC STREAM LFTMARGIN MINSPACE) (* scv " 1-Jul-85 11:29") (* prints PRINTSPEC on WINDOW and  returns the box taken by the  characters.) (PROG (YSTART YEND HEIGHT) (DSPXPOSITION LFTMARGIN STREAM) (SETQ YSTART (DSPYPOSITION NIL STREAM)) (for SPEC in PRINTSPEC bind OLDX PRETTYWIDTH do (SETQ OLDX (DSPXPOSITION NIL STREAM)) [SETQ PRETTYWIDTH (ITIMES (fetch (ATPRINTSPEC WIDTH) of SPEC) (CHARWIDTH (CHCON1 "M") (DSPFONT NIL STREAM] (COND ((fetch (ATPRINTSPEC LABEL) of SPEC) (PRIN3 (fetch (ATPRINTSPEC LABEL) of SPEC) STREAM) (PRIN3 " " STREAM))) (* If any single item won't fit,  skip a line and continue) (if (IGEQ (IDIFFERENCE (DSPXPOSITION NIL STREAM) OLDX) PRETTYWIDTH) then (TERPRI STREAM)) (DSPXPOSITION (IPLUS OLDX PRETTYWIDTH) STREAM)) (SETQ YEND (DSPYPOSITION NIL STREAM)) (RETURN (PROG1 (create REGION LEFT _ LFTMARGIN BOTTOM _ (IDIFFERENCE YEND (FONTPROP STREAM 'DESCENT)) HEIGHT _ (IPLUS (IDIFFERENCE YSTART YEND) (FONTPROP STREAM 'HEIGHT)) WIDTH _ (IDIFFERENCE (DSPXPOSITION NIL STREAM) LFTMARGIN)) (TERPRI STREAM]) (AT.MAKEHEADINGWINDOW [LAMBDA (WIDTH FONT BORDER TITLE) (* scv "23-May-85 11:56") (PROG (PWINDOW) (SETQ PWINDOW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ WIDTH HEIGHT _ (HEIGHTIFWINDOW (FONTPROP FONT 'HEIGHT) TITLE BORDER)) TITLE BORDER T)) (DSPFONT FONT PWINDOW) (PUTWINDOWPROP PWINDOW 'PAGEFULLFN (FUNCTION NILL)) (PUTWINDOWPROP PWINDOW 'NOSCROLLBARS T) (PUTWINDOWPROP PWINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (PUTWINDOWPROP PWINDOW 'REPAINTFN (FUNCTION AT.HEADINGWREDISPLAYFN)) (AT.MAKERIGIDWINDOW PWINDOW) (RETURN PWINDOW]) (AT.MAKECOUNTERWINDOW [LAMBDA (HEIGHT WIDTH AUTOTESTW) (* scv "30-May-85 16:59") (LET ((COUNTERW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ (HEIGHTIFWINDOW (FONTPROP DEFAULTAUTOTESTFONT 'HEIGHT)) WIDTH _ (WINDOWPROP AUTOTESTW 'WIDTH)) NIL NIL T))) (AT.MAKERIGIDWINDOW COUNTERW) (WINDOWPROP COUNTERW 'AUTOTESTERWINDOW AUTOTESTW) (WINDOWPROP COUNTERW 'REPAINTFN (FUNCTION AT.REPAINT.COUNTERW)) COUNTERW]) (AT.MAKETIMEWINDOW [LAMBDA (HEIGHT WIDTH AUTOTESTW) (* scv "15-Jul-85 15:36") (LET ((TIMEW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ (HEIGHTIFWINDOW (FONTPROP ATTIMEWINDOWFONT 'HEIGHT)) WIDTH _ (WINDOWPROP AUTOTESTW 'WIDTH)) NIL NIL T))) (AT.MAKERIGIDWINDOW TIMEW) (WINDOWPROP TIMEW 'AUTOTESTERWINDOW AUTOTESTW) (WINDOWPROP TIMEW 'REPAINTFN (FUNCTION AT.REPAINT.TIMEW)) (DSPFONT ATTIMEWINDOWFONT TIMEW) TIMEW]) (AT.PROMPTWPRINT [LAMBDA U (* Jellinek " 6-May-84 16:37") (PROG (WINDOW) (COND ((ILESSP U 2) (ERROR "not enough args to PROMPTWPRINT"))) (* CAR is window, CDR is height in  lines) [SETQ WINDOW (CAR (GETWINDOWPROP (ARG U 1) 'PROMPTWINDOW] (for ITEM from 2 to U do (PRIN1 (ARG U ITEM) WINDOW]) (AT.PROMPTWTERPRI [LAMBDA (MAINWINDOW) (* Jellinek " 6-May-84 16:37") (* CAR is prompt window, CDR is  height in lines) (TERPRI (CAR (GETWINDOWPROP MAINWINDOW 'PROMPTWINDOW]) (AT.SELECTFILE [LAMBDA (FOLDER WINDOW) (* scv "23-May-85 12:10") (COND (FOLDER (replace (TESTBUCKET SELECTED?) of FOLDER with T) (WINDOWADDPROP WINDOW 'CURRENTTESTNUMBERS (fetch (TESTBUCKET %#) of FOLDER)) [WINDOWPROP WINDOW 'CURRENTTESTNUMBERS (SORT (WINDOWPROP WINDOW 'CURRENTTESTNUMBERS] (\ITEMW.SELECTITEM (LIST (fetch (TESTBUCKET ITEMREGION) of FOLDER)) WINDOW]) (AT.UNSELECTFILE [LAMBDA (MSG WINDOW) (* scv "28-May-85 12:53") (COND (MSG (replace (TESTBUCKET SELECTED?) of MSG with NIL) [WINDOWPROP WINDOW 'CURRENTTESTNUMBERS (REMOVE (fetch (TESTBUCKET %#) of MSG) (WINDOWPROP WINDOW 'CURRENTTESTNUMBERS] (\ITEMW.DESELECTITEM (LIST (fetch ITEMREGION of MSG)) WINDOW]) (AT.CHANGECOMPLETEMARK [LAMBDA (TEST WINDOW) (* scv "28-May-85 12:37") (PROG ((TESTREGION (fetch ITEMREGION of TEST))) (BITBLT NIL 0 0 WINDOW (fetch (REGION LEFT) of TESTREGION) (IDIFFERENCE (fetch (REGION PTOP) of TESTREGION) (IQUOTIENT (FONTPROP WINDOW 'HEIGHT) 2)) (fetch (REGION WIDTH) of TESTREGION) 1 'TEXTURE 'INVERT BLACKSHADE]) (AT.SHOW.NUMCOMPLETED [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:30") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW 'COUNTERWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 2)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 3))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP COUNTERW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Completed:" COUNTERW) (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW 'NUMCOMPLETED) PRINTINGREGION COUNTERW]) (AT.SHOW.NUMFILES [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:28") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW 'COUNTERWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 0)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 1))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP COUNTERW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Files:" COUNTERW) (CENTERPRINTINREGION (LENGTH (WINDOWPROP AUTOTESTERW 'AUTOTESTERITEMMAP)) PRINTINGREGION COUNTERW]) (AT.SHOW.NUMSELECTED [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:35") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW 'COUNTERWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 1)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 2))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP COUNTERW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Selected:" COUNTERW) (CENTERPRINTINREGION (LENGTH (WINDOWPROP AUTOTESTERW 'CURRENTTESTNUMBERS)) PRINTINGREGION COUNTERW]) (AT.SHOW.NUMSUCCESSFUL [LAMBDA (AUTOTESTERW) (* scv "20-Jun-85 09:30") (LET ((COUNTERW (WINDOWPROP AUTOTESTERW 'COUNTERWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 3)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 4))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP COUNTERW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE COUNTERW) (DSPXPOSITION STARTPOSITION COUNTERW) (PRIN3 "Successful:" COUNTERW) (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW 'NUMSUCCESSFUL) PRINTINGREGION COUNTERW]) (AT.SHOW.ENDTIME [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 16:01") (LET ((TIMEW (WINDOWPROP AUTOTESTERW 'TIMEWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 3)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 4))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP TIMEW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "End:" TIMEW) (IF (WINDOWPROP AUTOTESTERW 'ENDTIME) THEN (CENTERPRINTINREGION (GDATE (WINDOWPROP AUTOTESTERW 'ENDTIME)) PRINTINGREGION TIMEW]) (AT.SHOW.STARTTIME [LAMBDA (AUTOTESTERW) (* scv "15-Jul-85 15:43") (LET ((TIMEW (WINDOWPROP AUTOTESTERW 'TIMEWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 2)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 3))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP TIMEW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "Start:" TIMEW) (IF (WINDOWPROP AUTOTESTERW 'STARTTIME) THEN (CENTERPRINTINREGION (GDATE (WINDOWPROP AUTOTESTERW 'STARTTIME)) PRINTINGREGION TIMEW]) (AT.SHOW.TESTID [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 13:49") (LET ((TIMEW (WINDOWPROP AUTOTESTERW 'TIMEWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 1)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 2))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP TIMEW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "ID:" TIMEW) (IF (WINDOWPROP AUTOTESTERW 'TESTID) THEN (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW 'TESTID) PRINTINGREGION TIMEW]) (AT.SHOW.TESTSUITE [LAMBDA (AUTOTESTERW) (* scv "12-Jul-85 13:47") (LET ((TIMEW (WINDOWPROP AUTOTESTERW 'TIMEWINDOW)) (STARTPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 0)) (ENDPOSITION (ITIMES (IQUOTIENT (WINDOWPROP AUTOTESTERW 'WIDTH) 4) 1))) (LET [(PRINTINGREGION (create REGION LEFT _ STARTPOSITION WIDTH _ (IDIFFERENCE ENDPOSITION STARTPOSITION) BOTTOM _ 0 HEIGHT _ (WINDOWPROP TIMEW 'HEIGHT] (DSPFILL PRINTINGREGION WHITESHADE 'REPLACE TIMEW) (DSPXPOSITION STARTPOSITION TIMEW) (PRIN3 "Suite:" TIMEW) (IF (WINDOWPROP AUTOTESTERW 'TESTSUITE) THEN (CENTERPRINTINREGION (WINDOWPROP AUTOTESTERW 'TESTSUITE) PRINTINGREGION TIMEW]) ) (* * window functions) (DEFINEQ (AT.HEADINGWREDISPLAYFN [LAMBDA (WINDOW) (* scv "24-May-85 17:06") (AT.PRINTHEADINGSON WINDOW (GETWINDOWPROP (GETWINDOWPROP WINDOW 'MAINWINDOW) 'INFOGOTTEN]) (AT.REPAINT.COUNTERW [LAMBDA (COUNTERWINDOW) (* scv "29-May-85 14:12") (LET [(AUTOTESTERW (WINDOWPROP COUNTERWINDOW 'AUTOTESTERWINDOW] (DSPFILL NIL WHITESHADE 'REPLACE COUNTERWINDOW) (AT.SHOW.NUMFILES AUTOTESTERW) (AT.SHOW.NUMSELECTED AUTOTESTERW) (AT.SHOW.NUMCOMPLETED AUTOTESTERW) (AT.SHOW.NUMSUCCESSFUL AUTOTESTERW]) (AT.REPAINT.TIMEW [LAMBDA (TIMEWINDOW) (* scv "12-Jul-85 13:16") (LET [(AUTOTESTERW (WINDOWPROP TIMEWINDOW 'AUTOTESTERWINDOW] (DSPFILL NIL WHITESHADE 'REPLACE TIMEWINDOW) (AT.SHOW.TESTSUITE AUTOTESTERW) (AT.SHOW.TESTID AUTOTESTERW) (AT.SHOW.STARTTIME AUTOTESTERW) (AT.SHOW.ENDTIME AUTOTESTERW]) (AT.ICONFN [LAMBDA (W I) (* scv " 3-Jun-85 14:41") (PROG (OLDICONREGION) [SETQ OLDICONREGION (AND I (GETWINDOWPROP I 'REGION] (RETURN (TITLEDICONW (create TITLEDICON ICON _ ATICON MASK _ ATICONMASK TITLEREG _ (create REGION LEFT _ 5 WIDTH _ 70 BOTTOM _ 45 HEIGHT _ 75)) (GETWINDOWPROP W 'ITEMSPEC) ATICONFONT (AND I (create POSITION XCOORD _ (fetch (REGION LEFT) of OLDICONREGION) YCOORD _ (fetch (REGION BOTTOM) of OLDICONREGION))) NIL 'TOP]) (AT.BUTTONEVENTFN [LAMBDA (WINDOW) (* scv "30-May-85 09:23") (AT.SELECT WINDOW]) (AT.CURSORMOVEDFN [LAMBDA (WINDOW) (* scv "29-May-85 09:49") (if (IGEQ AT.MARKXPOS (fetch XCOORD of (CURSORPOSITION NIL WINDOW))) then (SETCURSOR AT.RIGHTARROWCURSOR) else (if (NEQ (CURSOR) DEFAULTCURSOR) then (SETCURSOR DEFAULTCURSOR]) (AT.CURSOROUTFN [LAMBDA (WINDOW) (* rao%: "30-JUN-82 15:49") (SETCURSOR DEFAULTCURSOR]) (AT.REPAINTFN [LAMBDA (WINDOW R) (* scv "29-May-85 09:45") (PROG ((AUTOTESTERITEMMAP (GETWINDOWPROP WINDOW 'AUTOTESTERITEMMAP)) (HEADINGWINDOW (GETWINDOWPROP WINDOW 'HEADINGWINDOW)) (TOP (fetch (REGION TOP) of R)) [BOTTOM (IDIFFERENCE (fetch (REGION BOTTOM) of R) (FONTPROP WINDOW 'ASCENT] YPOS ITEMSPEC DIRWIDTH STARTOFNAME ATTRS) (COND ((NULL AUTOTESTERITEMMAP) (RETURN))) (for FILE in AUTOTESTERITEMMAP bind REGION do (if (AND [IGREATERP TOP (SETQ YPOS (fetch (REGION BOTTOM) of (SETQ REGION (fetch (TESTBUCKET ITEMREGION) of FILE] (ILESSP BOTTOM (fetch (REGION TOP) of REGION))) then (DSPYPOSITION (IDIFFERENCE (IPLUS (fetch (REGION BOTTOM) of REGION) (fetch (REGION HEIGHT) of REGION)) (FONTPROP WINDOW 'ASCENT)) WINDOW) (OR (EQUAL (AT.PRINTANDGETREGION (fetch (TESTBUCKET ITEM) of FILE) WINDOW AT.MARKXPOS 10) REGION) T (HELP)) (if (fetch (TESTBUCKET SELECTED?) of FILE) then (\ITEMW.SELECTITEM (LIST (fetch ITEMREGION of FILE)) WINDOW)) (if (fetch (TESTBUCKET COMPLETED?) of FILE) then (AT.CHANGECOMPLETEMARK FILE WINDOW))) repeatwhile (ILESSP BOTTOM YPOS]) (AT.SCROLLFN [LAMBDA (WINDOW HORIZ VERT CONTINUOUS?) (* scv "28-May-85 12:45") (* * Scroll AT window up/down and right/left.  In right/left case, tell heading window to scroll also) (* * only scroll an integral number of text lines) (if (GETWINDOWPROP WINDOW 'AUTOTESTERBUSY) then (AT.CLRPROMPTW WINDOW) (AT.PROMPTWPRINT WINDOW "The autotester is busy.") else (COND ((NOT (ZEROP HORIZ)) (SCROLLW (GETWINDOWPROP WINDOW 'HEADINGWINDOW) HORIZ VERT CONTINUOUS?))) (SCROLLBYREPAINTFN WINDOW HORIZ VERT CONTINUOUS?]) (AT.RIGHTBUTTONFN [LAMBDA (WINDOW) (* scv "29-May-85 09:45") (COND ((IGREATERP (LASTMOUSEX WINDOW) AT.MARKXPOS) (DOWINDOWCOM WINDOW)) (T (AT.SELECT WINDOW]) (AT.MENU.WHENSELECTEDFN [LAMBDA (Item Menu Key) (* scv "28-May-85 11:03") (ADD.PROCESS (LIST (FUNCTION AT.COMMANDDISPATCH) (KWOTE Item) (KWOTE Menu) (KWOTE Key)) 'NAME (PACK (LIST 'AT- (CAR Item]) (AT.CLOSEFN [LAMBDA (WINDOW) (* scv " 2-Jul-85 13:55") (* did you really want to close up  shop?) (* * do the right thing; if we are really closing, smash pointers which can  cause circularities, so everything gets collected) (PROG (PROC) (SETQ PROC (GETWINDOWPROP WINDOW 'TESTPROCESS)) (RETURN (COND (PROC (SUSPEND.PROCESS PROC) (if (MOUSECONFIRM "Tests in progress: " "Click left button to ABORT tests, right button to RESUME tests." (GETPROMPTWINDOW (MAINWINDOW WINDOW T))) then (DEL.PROCESS PROC) (PUTWINDOWPROP (GETWINDOWPROP WINDOW 'COUNTERWINDOW) 'AUTOTESTERWINDOW NIL) (PUTWINDOWPROP WINDOW 'ATDISPLAYSTREAM NIL) else (WAKE.PROCESS PROC) 'DON'T)) (T (PUTWINDOWPROP (GETWINDOWPROP WINDOW 'COUNTERWINDOW) 'AUTOTESTERWINDOW NIL) (PUTWINDOWPROP WINDOW 'ATDISPLAYSTREAM NIL]) (AT.HARDCOPYFN [LAMBDA (WINDOW IMAGESTREAM) (* scv " 1-Jul-85 14:15") (SETQ WINDOW (MAINWINDOW WINDOW T)) (PROG (XPOS FONTWIDTH) (printout IMAGESTREAM "Testing results for " (GETWINDOWPROP WINDOW 'ITEMSPEC) ":" T T) (SETQ FONTWIDTH (CHARWIDTH (CHCON1 "M") (DSPFONT NIL IMAGESTREAM))) (SETQ XPOS (DSPLEFTMARGIN NIL IMAGESTREAM)) (for I on ATINFOLISTINGWIDTHS by (CDDR I) do (printout IMAGESTREAM (fetch (ATPRINTSPEC LABEL) of (CADR I))) (DSPXPOSITION (SETQ XPOS (PLUS XPOS (ITIMES (fetch (ATPRINTSPEC WIDTH) of (CADR I)) FONTWIDTH))) IMAGESTREAM)) (TERPRI IMAGESTREAM) (for FILEENTRY in (for INDEX in (GETWINDOWPROP WINDOW 'CURRENTTESTNUMBERS) collect (CAR (NTH (GETWINDOWPROP WINDOW 'AUTOTESTERITEMMAP) INDEX))) do (AT.PRINTCOMMAND FILEENTRY 'RIGHT WINDOW IMAGESTREAM]) ) (* * odds and ends) (DEFINEQ (AT.FETCHFILENAME [LAMBDA (ENTRY) (* scv "24-May-85 16:45") (fetch (TESTBUCKET FILENAME) of ENTRY]) (AT.STARTOFNAME [LAMBDA (FILENAME SPEC) (* lmm "14-Sep-84 17:59") (* assume that hosts match) [SETQ SPEC (SUBSTRING SPEC (ADD1 (OR (LASTCHPOS (CHARCODE }) SPEC) 0] (bind (DIRSTART _ (ADD1 (OR (LASTCHPOS (CHARCODE }) FILENAME) 0))) DIREND first (SETQ FILENAME (SUBSTRING FILENAME DIRSTART)) while (SETQ DIREND (LASTCHPOS (CHARCODE >) SPEC)) do (SETQ SPEC (SUBSTRING SPEC 1 DIREND SPEC)) [if (STRPOS SPEC FILENAME 1 NIL T NIL (UPPERCASEARRAY)) then (RETURN (IPLUS DIRSTART (NCHARS SPEC] (SETQ SPEC (SUBSTRING SPEC 1 -2 SPEC)) finally (RETURN DIRSTART]) (AT.STARTUP [LAMBDA (WINDOW COMMANDMENU COMMANDMENUWINDOW) (* scv "20-Jun-85 11:05") (PROG ((DIR (FASSOC 'DIRECTORY ATMENUITEMS))) (RESETLST (RESETSAVE NIL (LIST 'SHADEITEM DIR COMMANDMENU WHITESHADE)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (W P) (PUTWINDOWPROP W 'AUTOTESTERBUSY P] WINDOW NIL)) (SHADEITEM DIR COMMANDMENU ATITEMSELECTEDSHADE COMMANDMENUWINDOW) (PUTWINDOWPROP WINDOW 'AUTOTESTERBUSY T) (AT.UPDATEAUTOTESTERITEMS (GETWINDOWPROP WINDOW 'ITEMSPEC) WINDOW))]) (AT.CREATEPRINTSPEC [LAMBDA (FILEINFO WANTTOSEE NAMESTART) (* scv "13-Jun-85 17:23") (for HEADING in ATINFOLISTINGWIDTHS by (CDDR HEADING) when (FMEMB HEADING WANTTOSEE) collect (create ATPRINTSPEC LABEL _ [COND ((EQ HEADING 'FILE) (SUBSTRING (CDR (FASSOC HEADING FILEINFO)) NAMESTART)) (T (CDR (FASSOC HEADING FILEINFO] WIDTH _ (fetch (ATPRINTSPEC WIDTH) of (LISTGET ATINFOLISTINGWIDTHS HEADING]) (AT.FINDTESTBUCKET [LAMBDA (WINDOW) (* scv "22-May-85 15:30") (for TEST in (WINDOWPROP WINDOW 'AUTOTESTERITEMMAP) bind [YPOS _ (IPLUS (LASTMOUSEY WINDOW) (FONTPROP WINDOW 'DESCENT] thereis (IGREATERP YPOS (fetch BOTTOM of (fetch (TESTBUCKET ITEMREGION) of TEST]) (AT.PROMPTFORINPUT [LAMBDA (PROMPT EXPRS WINDOW) (* hdj " 1-Sep-84 15:58") (PROMPTFORWORD PROMPT EXPRS NIL (CAR (GETWINDOWPROP WINDOW 'PROMPTWINDOW)) NIL 'TTY (CHARCODE (CR ESC]) (AT.GETALLFILEINFO [LAMBDA (FILE GENERATOR ATTRIBUTES) (* scv "13-Jun-85 16:15") (* *) (for ATTR in ATTRIBUTES collect (if (EQ ATTR 'FILE) then (CONS ATTR FILE) elseif (EQ ATTR 'NAME) then (CONS ATTR (FILENAMEFIELD FILE 'NAME)) elseif (EQ ATTR 'RESULT) then (CONS ATTR '?) else (CONS ATTR (\GENERATEFILEINFO GENERATOR ATTR]) (AT.GETPRINTDESTINATION [LAMBDA (KEY) (* scv " 2-Jul-85 10:24") (if (EQ KEY 'LEFT) then (OPENIMAGESTREAM '{LPT}) else (SELECTQ (MENU (create MENU ITEMS _ '(File Printer) TITLE _ "Print where?" MENUCOLUMNS _ 1)) (File [PROG (FILE) (SETQ FILE (GetImageFile)) (RETURN (OPENIMAGESTREAM (CAR FILE) (CDR FILE]) (Printer (OPENIMAGESTREAM (PACKFILENAME 'HOST 'LPT 'NAME (GetPrinterName)))) (SHOULDNT "Bad printer destination"]) (AT.\ItemWithTag [LAMBDA (TAG ITEMS) (* hdj "16-Sep-84 16:16") (* * search a menu's items for one with tag TAG) (for ITEM in ITEMS do (if (EQ (CADR ITEM) TAG) then (RETURN ITEM]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ AT.MARKXPOS 16) (CONSTANTS (AT.MARKXPOS 16)) ) (DECLARE%: EVAL@COMPILE (RECORD ATPRINTSPEC (LABEL . WIDTH)) (RECORD TESTBUCKET (FILENAME ITEMREGION %# SELECTED? COMPLETED? SUCCESSFUL? ITEM)) ) ) (ADDTOVAR BackgroundMenuCommands ("AutomatedTester" (AT) "Opens an automated tester window; prompts for directory" )) (RPAQQ BackgroundMenu NIL) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA AT) (ADDTOVAR NLAML ) (ADDTOVAR LAMA AT.PROMPTWPRINT) ) (PUTPROPS AUTOTEST COPYRIGHT ("XEROX Corporation" 1985 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9502 16804 (AT 9512 . 9747) (AUTOTESTER 9749 . 14850) (SINGLE-TEST 14852 . 16624) ( TEST-MESSAGE 16626 . 16802)) (16849 25928 (AT.TESTCOMMAND 16859 . 19699) (AT.ABORTCOMMAND 19701 . 22058) (AT.PAUSECOMMAND 22060 . 22499) (AT.RESUMECOMMAND 22501 . 24307) (AT.DIRECTORYCOMMAND 24309 . 25012) (AT.PRINTCOMMAND 25014 . 25793) (AT.QUITCOMMAND 25795 . 25926)) (25929 44896 ( AT.COMMANDDISPATCH 25939 . 34567) (AT.SELECT 34569 . 36627) (AT.UPDATEAUTOTESTERITEMS 36629 . 42512) ( AT.SINGLE-TEST 42514 . 44894)) (44936 63489 (AT.MAKERIGIDWINDOW 44946 . 45356) (AT.CLRPROMPTW 45358 . 45531) (AT.PRINTHEADINGSON 45533 . 47560) (AT.PRINTANDGETREGION 47562 . 49679) (AT.MAKEHEADINGWINDOW 49681 . 50599) (AT.MAKECOUNTERWINDOW 50601 . 51336) (AT.MAKETIMEWINDOW 51338 . 52008) (AT.PROMPTWPRINT 52010 . 52600) (AT.PROMPTWTERPRI 52602 . 52956) (AT.SELECTFILE 52958 . 53472) (AT.UNSELECTFILE 53474 . 53966) (AT.CHANGECOMPLETEMARK 53968 . 54537) (AT.SHOW.NUMCOMPLETED 54539 . 55627) (AT.SHOW.NUMFILES 55629 . 56723) (AT.SHOW.NUMSELECTED 56725 . 57826) (AT.SHOW.NUMSUCCESSFUL 57828 . 58919) ( AT.SHOW.ENDTIME 58921 . 60062) (AT.SHOW.STARTTIME 60064 . 61213) (AT.SHOW.TESTID 61215 . 62344) ( AT.SHOW.TESTSUITE 62346 . 63487)) (63519 73071 (AT.HEADINGWREDISPLAYFN 63529 . 63788) ( AT.REPAINT.COUNTERW 63790 . 64219) (AT.REPAINT.TIMEW 64221 . 64628) (AT.ICONFN 64630 . 65715) ( AT.BUTTONEVENTFN 65717 . 65857) (AT.CURSORMOVEDFN 65859 . 66240) (AT.CURSOROUTFN 66242 . 66385) ( AT.REPAINTFN 66387 . 68973) (AT.SCROLLFN 68975 . 69680) (AT.RIGHTBUTTONFN 69682 . 69935) ( AT.MENU.WHENSELECTEDFN 69937 . 70273) (AT.CLOSEFN 70275 . 71712) (AT.HARDCOPYFN 71714 . 73069)) (73098 78522 (AT.FETCHFILENAME 73108 . 73272) (AT.STARTOFNAME 73274 . 74243) (AT.STARTUP 74245 . 74930) ( AT.CREATEPRINTSPEC 74932 . 75777) (AT.FINDTESTBUCKET 75779 . 76237) (AT.PROMPTFORINPUT 76239 . 76493) (AT.GETALLFILEINFO 76495 . 77374) (AT.GETPRINTDESTINATION 77376 . 78160) (AT.\ItemWithTag 78162 . 78520))))) STOP \ No newline at end of file diff --git a/internal/test/tools/AUTOTEST.DFASL b/internal/test/tools/AUTOTEST.DFASL new file mode 100644 index 00000000..4741471a Binary files /dev/null and b/internal/test/tools/AUTOTEST.DFASL differ diff --git a/internal/test/tools/AUTOTEST.LCOM b/internal/test/tools/AUTOTEST.LCOM deleted file mode 100644 index 249539ca..00000000 Binary files a/internal/test/tools/AUTOTEST.LCOM and /dev/null differ diff --git a/internal/test/tools/AUTOTEST.TEDIT b/internal/test/tools/AUTOTEST.TEDIT index 9793decd..e2bdb991 100644 --- a/internal/test/tools/AUTOTEST.TEDIT +++ b/internal/test/tools/AUTOTEST.TEDIT @@ -1,3 +1 @@ -AUTOMATED TEST HARNESS INTERFACES This document specifies the interfaces to the automated tester harness. The harness is composed of two parts: the top-level tester and the individual test handler. The name of the file to load for this is AUTOTEST.DCOM in the top level of the standard test directory. [We need to set up this standard test directory.] The top-level tester is set up similarly to the package FileBrowser. Items are selected in the same manner as FileBrowser, and are displayed similarly. The portions of the display are as follows (from top to bottom): 1. A prompt window for displaying messages and getting new input. 2. A command menu with the following commands: TEST Tests sequentially each of the items selected in the test files window. Testing consists of loading the file containing the test suite, calling a function which has the same name as the NAME field of the filename (this function must return NIL iff the test suite is not successful), then undoing (as best as possible) the side-effects of loading and running the test suite. The function which is called is passed one argument: the name of the directory that the test suite came from (including the host name). If this item is selected with the middle button, then first it asks for the name of the file to direct output to (selecting this item with the left button will direct output to T, the process' TTY display stream), before running the test suites. All output directed to NIL, the default output stream, will go to this file, including all error messages generated by the automated test harness and by TEST-MESSAGE (see below). It is assumed that no other activity is being performed while testing is in progress. ABORT Aborts any tests in progress. Confirmation (via clicking the left mouse button) is required. New tests can be selected, tests can be re-run, etc. after an abort. PAUSE Temporarily pauses any tests in progress. Any pause time does not count in the computation of timeouts (see below). RESUME Resumes PAUSEd testing. DIRECTORY Does a directory of files (the directory pattern is prompted for in the prompt window) and puts them in the test files window in order to have a new set of test suites to select from. PRINT Prints the results of testing the selected files. Selecting this item with the left button will print on the default printer. Selecting this item with the middle button will put up a menu asking whether to print to a printer or a file. If a printer is selected, then a menu asking for the printer to print to (gotten from DEFAULTPRINTINGHOST plus the selection "Other"; the latter will ask for the name of a new printer to print to) is put up. Otherwise, if a file is selected, then the user will be prompted for the name of a file to print to (also, if the type of output is not obvious, i.e. PRESS or INTERPRESS, then the user will be prompted for the type of output). When the Hardcopy item of the right button menu is selected for this window, then this command is performed (except that selecting the main item does the default, while selecting either the printer or the file sub-item starts the sequence of questions at the intuitive place). SUMMARIZE Similar to PRINT, except that it prints only those tests (out of the selected tests) which failed. QUIT Quits testing, closing the window and throwing away all test results, test names, etc. stored in the window. If any tests are currently in progress, then confirmation (via clicking the left mouse button) is required in order to quit (in this case an ABORT is performed before quitting). When the tester window is closed, this command is performed. 3. A status window, which has the following fields: Suite The name of the test suite currently running. ID The ID of the current test being performed by SINGLE-TEST. Start The time that the current test was started. End The time that the current test will time out at, or blank if none. 4. A summary window, which has the following fields: Files The number of files in the test files window. Selected The number of files (test suites) selected in the test files window. Completed The number of test suites completed. Successful The number of test suites which were successful. 5. The directory pattern used to select the test suite files. Unless otherwise overridden, the directory pattern by default only selects the latest version of each test suite file. Also, unless otherwise overridden, the directory pattern by default only selects .DCOM files (if a source file is more recent than the corresponding compiled file, then an error message is displayed). 6. A heading line which identifies each column in the test files window. 7. The test files window which has a line for each test suite file which matches the directory pattern. The left button on an entry selects only that entry. The middle button on an unselected entry adds that entry to the selected entries. The middle button on a selected entry removes that entry from the selected entries. The right button in the left portion of an entry will extend the current entries to include this entry and all the entries inbetween (the mouse cursor will change to a right pointing arrow when this action is enabled). This window is also scrollable (both vertically and horizontally). When each test is completed, a line is drawn through the entry. This window has the following columns: Result: The result of testing using the corresponding test file. The following can appear in this column: ? The test suite has not been completed or possibly even initiated, so no results are known. pass The test suite completed successfully. FAIL The test suite did not complete successfully. This could be because a test in the test suite returned bad results, a test in the test suite aborted, a test in the test suite timed out, etc.. Name: The NAME portion of the test suite file name. File: The full name of the test suite file (except for the host name). When the tester is loaded, a new entry is added to the background menu, labelled AutomatedTester. When this is selected, an automated tester process is started, which will prompt (in the system prompt window) for a directory pattern which is used to initialize the test files window. The individual test handler is a function which is called by the top-level function of each test suite (the function which was called by the top-level tester). This function has the following interface (all arguments must be supplied): Name: SINGLE-TEST (LAMBDA function). Arguments: IDENTIFIER The integer identifier of this test. Identifiers are assigned manually and are unique across all tests in all test suites. [We need to set up an index file for this purpose, in the standard test directory.] EXPRESSION The expression to evaluate (e.g. (PLUS 2 3)). Note that in order to get the right results, this argument would normally be quoted with QUOTE (or ') or be an expression such as (QUOTE (fn)), where fn is a separately defined function (and is therefore compiled code, instead of interpreted code). PREDICATE The (one argument) predicate to check the result (e.g. (LAMBDA (X) (EQP X 5)) or NULL). This must be NIL iff the result was not correct (non-NIL indicates that the result was correct). If more than one error can occur, then output identifying the specific error should printed (to NIL). Note that this argument would normally be quoted with QUOTE (or ') or FUNCTION in order to get the right results. TIMEOUT The maximum elapsed (wall) time (in milliseconds) that the expression EXPRESSION should take to complete (NIL implies that no timeout is to be used). With the current Interlisp-D process mechanism, this will only work if the expression (or anything it calls) does a BLOCK, so that another process can check to see whether a timeout has occurred. Also, the timing is not exact, so the actual timeout used will be no less than the value supplied. Time elapsed while the test was PAUSEd is not counted in checking for a timeout. Result: NIL iff the test was not successful (due to PREDICATE returning NIL, a NOBIND being returned, a timeout occurring, or a deep exit (such as an abort) occurring). Non-NIL indicates success. Description: This function evaluates the expression EXPRESSION and checks the result with the predicate PREDICATE, returning the result from calling PREDICATE. If NOBIND is returned from either EXPRESSION or PREDICATE, then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If the timeout is exceeded (and timeouts can be checked) then the evaluation of the expression is aborted and an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If a deep exit occured in either EXPRESSION or PREDICATE (e.g. from aborting of the expression), then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. Side Effects: A message can be printed (to NIL). Assumptions: Deep exits completely out of EXPRESSION or PREDICATE are not part of the successful behaviour of either EXPRESSION or PREDICATE (any such exits must be caught internally within EXPRESSION or PREDICATE). Note that deep exits are caught via ERRORSET, so RETFROM, RETTO, RETEVAL, RESUME, etc. are not caught. There is a function available which prints out an easily identifiable error message in a standard format to the standard ouput. Thisfunction has the following interface (all arguments must be supplied): Name: TEST-MESSAGE (LAMBDA function). Arguments: IDENTIFIER The integer identifier of this test (as given to SINGLE-TEST). TEXT The text of the error message. INFO Information specific to this instance of this error. Result: Not useful. Description: The error message along with the test identifier and the specific information is printed to NIL in a standard, easy to notice format. Side Effects: A message is printed (to NIL). Assumptions: None. Some side-effects of the automated test harness are: 1. The History List for the Programmer's Assistant is used, therefore old items are lost and a REDO, etc. immediately after testing will redo the last command that the automated test harness performed, not the last item printed in the top level typescript window. 2. The top level value and the value in the Programmer's Assistant of HELPFLAG are changed for the duration of running a test suite. 3. Extra processes are run to perform the testing. Known deficiencies with the implementation are: 1. ABORTing and PAUSEing can only be done between individual tests. 2. If a test is aborted between individual tests, but not between tests suites, then the effects of LOADing and running that test suite are not UNDOne. 3. Some errors are not caught, and some side effects are not undone if errors occur. Some possible extensions to this package are: 1. Utilities to help with testing for deliberate errors. 2. Utilities to help with automating input which would normally be manual. (LIST ((PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL)))))<–Ô–x¨Ô¨<xÔx<Ô<ÔTÔTCLASSIC -CLASSIC -"1ÛB/ª{¿mc44>2G54N/<€IÏk],Å4Hí% ˆS3ŸÆŸ1@Í& J$:”-5…30D˜U.9K*Ɉz¹ \ No newline at end of file +AUTOMATED TEST HARNESS INTERFACES This document specifies the interfaces to the automated tester harness. The harness is composed of two parts: the top-level tester and the individual test handlers, The name of the file to load for this is AUTOTEST.LCOM in the top level of the {$MEDLEY}internal/test directory. The top-level tester is set up similarly to the package FileBrowser. Items are selected in the same manner as FileBrowser, and are displayed similarly. The portions of the display are as follows (from top to bottom): 1. A prompt window for displaying messages and getting new input. 2. A command menu with the following commands: TEST Tests sequentially each of the items selected in the test files window. Testing consists of loading the file containing the test suite, calling a function which has the same name as the NAME field of the filename (this function must return NIL iff the test suite is not successful), then undoing (as best as possible) the side-effects of loading and running the test suite. The function which is called is passed one argument: the name of the directory that the test suite came from (including the host name). If this item is selected with the middle button, then first it asks for the name of the file to direct output to (selecting this item with the left button will direct output to T, the process' TTY display stream), before running the test suites. All output directed to NIL, the default output stream, will go to this file, including all error messages generated by the automated test harness and by TEST-MESSAGE (see below). It is assumed that no other activity is being performed while testing is in progress. ABORT Aborts any tests in progress. Confirmation (via clicking the left mouse button) is required. New tests can be selected, tests can be re-run, etc. after an abort. PAUSE Temporarily pauses any tests in progress. Any pause time does not count in the computation of timeouts (see below). RESUME Resumes PAUSEd testing. DIRECTORY Does a directory of files (the directory pattern is prompted for in the prompt window) and puts them in the test files window in order to have a new set of test suites to select from. PRINT Prints the results of testing the selected files. Selecting this item with the left button will print on the default printer. Selecting this item with the middle button will put up a menu asking whether to print to a printer or a file. If a printer is selected, then a menu asking for the printer to print to (gotten from DEFAULTPRINTINGHOST plus the selection "Other"; the latter will ask for the name of a new printer to print to) is put up. Otherwise, if a file is selected, then the user will be prompted for the name of a file to print to (also, if the type of output is not obvious, i.e. PRESS or INTERPRESS, then the user will be prompted for the type of output). When the Hardcopy item of the right button menu is selected for this window, then this command is performed (except that selecting the main item does the default, while selecting either the printer or the file sub-item starts the sequence of questions at the intuitive place). SUMMARIZE Similar to PRINT, except that it prints only those tests (out of the selected tests) which failed. QUIT Quits testing, closing the window and throwing away all test results, test names, etc. stored in the window. If any tests are currently in progress, then confirmation (via clicking the left mouse button) is required in order to quit (in this case an ABORT is performed before quitting). When the tester window is closed, this command is performed. 3. A status window, which has the following fields: Suite The name of the test suite currently running. ID The ID of the current test being performed by SINGLE-TEST. Start The time that the current test was started. End The time that the current test will time out at, or blank if none. 4. A summary window, which has the following fields: Files The number of files in the test files window. Selected The number of files (test suites) selected in the test files window. Completed The number of test suites completed. Successful The number of test suites which were successful. 5. The directory pattern used to select the test suite files. Unless otherwise overridden, the directory pattern by default only selects the latest version of each test suite file. Also, unless otherwise overridden, the directory pattern by default only selects .LCOM files (if a source file is more recent than the corresponding compiled file, then an error message is displayed). 6. A heading line which identifies each column in the test files window. 7. The test files window which has a line for each test suite file which matches the directory pattern. The left button on an entry selects only that entry. The middle button on an unselected entry adds that entry to the selected entries. The middle button on a selected entry removes that entry from the selected entries. The right button in the left portion of an entry will extend the current entries to include this entry and all the entries inbetween (the mouse cursor will change to a right pointing arrow when this action is enabled). This window is also scrollable (both vertically and horizontally). When each test is completed, a line is drawn through the entry. This window has the following columns: Result: The result of testing using the corresponding test file. The following can appear in this column: ? The test suite has not been completed or possibly even initiated, so no results are known. pass The test suite completed successfully. FAIL The test suite did not complete successfully. This could be because a test in the test suite returned bad results, a test in the test suite aborted, a test in the test suite timed out, etc.. Name: The NAME portion of the test suite file name. File: The full name of the test suite file (except for the host name). When the tester is loaded, a new entry is added to the background menu, labelled AutomatedTester. When this is selected, an automated tester process is started, which will prompt (in the system prompt window) for a directory pattern which is used to initialize the test files window. The individual test handler is a function which is called by the top-level function of each test suite (the function which was called by the top-level tester). This function has the following interface (all arguments must be supplied): Name: SINGLE-TEST (LAMBDA function). Arguments: IDENTIFIER The integer identifier of this test. Identifiers are assigned manually and are unique across all tests in all test suites. [We need to set up an index file for this purpose, in the standard test directory.] EXPRESSION The expression to evaluate (e.g. (PLUS 2 3)). Note that in order to get the right results, this argument would normally be quoted with QUOTE (or ') or be an expression such as (QUOTE (fn)), where fn is a separately defined function (and is therefore compiled code, instead of interpreted code). PREDICATE The (one argument) predicate to check the result (e.g. (LAMBDA (X) (EQP X 5)) or NULL). This must be NIL iff the result was not correct (non-NIL indicates that the result was correct). If more than one error can occur, then output identifying the specific error should printed (to NIL). Note that this argument would normally be quoted with QUOTE (or ') or FUNCTION in order to get the right results. TIMEOUT The maximum elapsed (wall) time (in milliseconds) that the expression EXPRESSION should take to complete (NIL implies that no timeout is to be used). With the current Interlisp-D process mechanism, this will only work if the expression (or anything it calls) does a BLOCK, so that another process can check to see whether a timeout has occurred. Also, the timing is not exact, so the actual timeout used will be no less than the value supplied. Time elapsed while the test was PAUSEd is not counted in checking for a timeout. Result: NIL iff the test was not successful (due to PREDICATE returning NIL, a NOBIND being returned, a timeout occurring, or a deep exit (such as an abort) occurring). Non-NIL indicates success. Description: This function evaluates the expression EXPRESSION and checks the result with the predicate PREDICATE, returning the result from calling PREDICATE. If NOBIND is returned from either EXPRESSION or PREDICATE, then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If the timeout is exceeded (and timeouts can be checked) then the evaluation of the expression is aborted and an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If a deep exit occured in either EXPRESSION or PREDICATE (e.g. from aborting of the expression), then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. Side Effects: A message can be printed (to NIL). Assumptions: Deep exits completely out of EXPRESSION or PREDICATE are not part of the successful behaviour of either EXPRESSION or PREDICATE (any such exits must be caught internally within EXPRESSION or PREDICATE). Note that deep exits are caught via ERRORSET, so RETFROM, RETTO, RETEVAL, RESUME, etc. are not caught. There is a function available which prints out an easily identifiable error message in a standard format to the standard ouput. Thisfunction has the following interface (all arguments must be supplied): Name: TEST-MESSAGE (LAMBDA function). Arguments: IDENTIFIER The integer identifier of this test (as given to SINGLE-TEST). TEXT The text of the error message. INFO Information specific to this instance of this error. Result: Not useful. Description: The error message along with the test identifier and the specific information is printed to NIL in a standard, easy to notice format. Side Effects: A message is printed (to NIL). Assumptions: None. Some side-effects of the automated test harness are: 1. The History List for the Programmer's Assistant is used, therefore old items are lost and a REDO, etc. immediately after testing will redo the last command that the automated test harness performed, not the last item printed in the top level typescript window. 2. The top level value and the value in the Programmer's Assistant of HELPFLAG are changed for the duration of running a test suite. 3. Extra processes are run to perform the testing. Known deficiencies with the implementation are: 1. ABORTing and PAUSEing can only be done between individual tests. 2. If a test is aborted between individual tests, but not between tests suites, then the effects of LOADing and running that test suite are not UNDOne. 3. Some errors are not caught, and some side effects are not undone if errors occur. Some possible extensions to this package are: 1. Utilities to help with testing for deliberate errors. 2. Utilities to help with automating input which would normally be manual. ...H...TERMINAL GACHA CLASSIC CLASSIC "t +  ÛB/  {¿mc44?2G54N/<€IÏd],Å0Cí% Ü3ŸÆŸ1@Ì& J$:”-5_¥F 630;˜U.9K*¢zº \ No newline at end of file diff --git a/internal/test/tools/DO-TEST.DFASL b/internal/test/tools/DO-TEST.DFASL index 6c7f65a0..f4890db9 100644 Binary files a/internal/test/tools/DO-TEST.DFASL and b/internal/test/tools/DO-TEST.DFASL differ diff --git a/internal/test/tools/DO-TEST.LCOM b/internal/test/tools/DO-TEST.LCOM deleted file mode 100644 index fb8a74a7..00000000 Binary files a/internal/test/tools/DO-TEST.LCOM and /dev/null differ