So far, it looks like every file with through tr '\r\n' '\n\r' swapping cr and lf.
This commit is contained in:
Larry Masinter
1693
internal/test/tools/AUTOTEST
Normal file
1693
internal/test/tools/AUTOTEST
Normal file
File diff suppressed because it is too large
Load Diff
BIN
internal/test/tools/AUTOTEST.LCOM
Normal file
BIN
internal/test/tools/AUTOTEST.LCOM
Normal file
Binary file not shown.
3
internal/test/tools/AUTOTEST.TEDIT
Normal file
3
internal/test/tools/AUTOTEST.TEDIT
Normal file
File diff suppressed because one or more lines are too long
66
internal/test/tools/AUTOTEST.TEDIT-orig
Normal file
66
internal/test/tools/AUTOTEST.TEDIT-orig
Normal file
@@ -0,0 +1,66 @@
|
||||
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Ô T CLASSIC
|
||||
BIN
internal/test/tools/DO-TEST
Normal file
BIN
internal/test/tools/DO-TEST
Normal file
Binary file not shown.
54
internal/test/tools/DO-TEST-MENU
Normal file
54
internal/test/tools/DO-TEST-MENU
Normal file
@@ -0,0 +1,54 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED " 1-Mar-88 15:02:43" {ERINYES}<CATE3>SEDIT>DO-TEST-MENU.\;2 2579
|
||||
|
||||
|changes| |to:| (VARS DO-TEST-MENUCOMS)
|
||||
(FUNCTIONS XCL-TEST::DO-TEST-MENU-SETUP XCL-TEST::DO-TEST-MENU-MESSAGE
|
||||
XCL-TEST::DO-TEST-MENU-CLEANUP XCL-USER::DO-TEST-MENU-CLEANUP
|
||||
XCL-USER::DO-TEST-MENU-MESSAGE XCL-USER::DO-TEST-MENU-SETUP)
|
||||
|
||||
|previous| |date:| "29-Feb-88 17:46:54" {ERINYES}<CATE3>SEDIT>DO-TEST-MENU.\;1)
|
||||
|
||||
|
||||
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(PRETTYCOMPRINT DO-TEST-MENUCOMS)
|
||||
|
||||
(RPAQQ DO-TEST-MENUCOMS ((FUNCTIONS XCL-TEST::DO-TEST-MENU-CLEANUP XCL-TEST::DO-TEST-MENU-MESSAGE
|
||||
XCL-TEST::DO-TEST-MENU-SETUP)))
|
||||
|
||||
(CL:DEFUN XCL-TEST::DO-TEST-MENU-CLEANUP (XCL-TEST::WINDOW-LIST)
|
||||
"This lets us clean up things, close the window and so on"
|
||||
(TEDIT.QUIT (CL:SECOND XCL-TEST::WINDOW-LIST))
|
||||
(CLOSEW (CL:FIRST XCL-TEST::WINDOW-LIST)))
|
||||
|
||||
|
||||
(CL:DEFUN XCL-TEST::DO-TEST-MENU-MESSAGE (XCL-TEST::WINDOW-LIST XCL-TEST::IMPORTANT XCL-TEST::MESSAGE
|
||||
) "The window list is built in do-test-menu-setup"
|
||||
(LET* ((XCL-TEST::WINDOW (CL:FIRST XCL-TEST::WINDOW-LIST))
|
||||
(STREAM (CL:SECOND XCL-TEST::WINDOW-LIST))
|
||||
(XCL-TEST::STREAM-LENGTH (GETFILEINFO STREAM 'LENGTH))
|
||||
(XCL-TEST::REGION (WINDOWPROP XCL-TEST::WINDOW 'REGION))
|
||||
(XCL-TEST::X-POSITION (CL:FIRST XCL-TEST::REGION))
|
||||
(XCL-TEST::Y-POSITION (+ (CL:SECOND XCL-TEST::REGION)
|
||||
(CL:FOURTH XCL-TEST::REGION)))
|
||||
(XCL-TEST::RESULTS NIL))
|
||||
(TEDIT.DELETE STREAM 0 XCL-TEST::STREAM-LENGTH)
|
||||
(TEDIT.INSERT STREAM XCL-TEST::MESSAGE)
|
||||
(MENU (CREATE MENU
|
||||
ITEMS _ '((XCL-TEST::SUCCESS T)
|
||||
(XCL-TEST::FAILURE NIL))
|
||||
MENUROWS _ 1)
|
||||
(CONS XCL-TEST::X-POSITION XCL-TEST::Y-POSITION)
|
||||
T)))
|
||||
|
||||
|
||||
(CL:DEFUN XCL-TEST::DO-TEST-MENU-SETUP (XCL-TEST::TEST-GROUP-TITTLE)
|
||||
"Set up a TEdit window to put text in giving instructions"
|
||||
(LET* ((XCL-TEST::WINDOW (CREATEW NIL XCL-TEST::TEST-GROUP-TITTLE))
|
||||
(STREAM (OPENTEXTSTREAM NIL XCL-TEST::WINDOW)))
|
||||
(LIST XCL-TEST::WINDOW STREAM)))
|
||||
|
||||
(PUTPROPS DO-TEST-MENU COPYRIGHT ("Xerox Corporation" 1988))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
BIN
internal/test/tools/DO-TEST-MENU.DFASL
Normal file
BIN
internal/test/tools/DO-TEST-MENU.DFASL
Normal file
Binary file not shown.
BIN
internal/test/tools/DO-TEST.DFASL
Normal file
BIN
internal/test/tools/DO-TEST.DFASL
Normal file
Binary file not shown.
242
internal/test/tools/FDEVTEST
Normal file
242
internal/test/tools/FDEVTEST
Normal file
@@ -0,0 +1,242 @@
|
||||
(FILECREATED " 6-Sep-85 10:23:52" {DSK}<LISPFILES>FDEVTEST.;2
|
||||
|
||||
changes to: (VARS FDEVTESTCOMS))
|
||||
|
||||
|
||||
(* Lots more has to be done here but I have the basic data structures here needed to create the test code)
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT FDEVTESTCOMS)
|
||||
|
||||
(RPAQQ FDEVTESTCOMS [(RECORDS FDEV)
|
||||
(MACROS .APPLY. FDEVOP)
|
||||
(P (MOVD (QUOTE APPLY*)
|
||||
(QUOTE SPREADAPPLY*])
|
||||
[DECLARE: EVAL@COMPILE
|
||||
|
||||
(DATATYPE FDEV ((DEVICENAME POINTER)
|
||||
(RESETABLE FLAG)
|
||||
(RANDOMACCESSP FLAG)
|
||||
(NODIRECTORIES FLAG)
|
||||
(PAGEMAPPED FLAG) (* True if i/o handled by pmap routines)
|
||||
(FDBINABLE FLAG) (* Copied as a microcode flag for INPUT streams formed on this
|
||||
device)
|
||||
(FDBOUTABLE FLAG)
|
||||
(FDEXTENDABLE FLAG)
|
||||
(BUFFERED FLAG) (* True implies that the device supports the BIN & BOUT uCode
|
||||
conventions, and implements the GETNEXTBUFFER method)
|
||||
(* Device operations:)
|
||||
(REMOTEP FLAG) (* true if device not local to machine)
|
||||
(SUBDIRECTORIES FLAG) (* true if device has real subdirectories)
|
||||
(NIL 6 FLAG)
|
||||
(CLOSEFILE POINTER) (* (stream) => closes stream, returns it)
|
||||
(DELETEFILE POINTER) (* (name) => deletes file so named, returning name, or NIL on
|
||||
failure. RECOG=OLDEST)
|
||||
(DIRECTORYNAMEP POINTER) (* (host/dir) => true if directory exists on host)
|
||||
(EVENTFN POINTER) (* (device event), called before/after logout, sysout,
|
||||
makesys)
|
||||
(GENERATEFILES POINTER)
|
||||
|
||||
(* (device pattern) => generator object for files matching pattern. Car of object is generator function, cdr is
|
||||
arbitrary state. Generator fn returns next file, or NIL when finished)
|
||||
|
||||
|
||||
(GETFILEINFO POINTER) (* (stream/name attribute device) => value of attribute for
|
||||
open stream or name of closed file)
|
||||
(GETFILENAME POINTER) (* (name recog device) => full file name)
|
||||
(HOSTNAMEP POINTER)
|
||||
|
||||
(* (hostname {device}) => T if hostname is valid. If device is given, return a FDEV for this {new} host, or T to use
|
||||
existing device)
|
||||
|
||||
|
||||
(OPENFILE POINTER) (* (name access recog otherinfo device) => new stream open on
|
||||
this device, or NIL if name not found)
|
||||
(READPAGES POINTER)
|
||||
|
||||
(* (stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers
|
||||
or a single buffer (the usual case))
|
||||
|
||||
|
||||
(REOPENFILE POINTER)
|
||||
|
||||
(* (name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so
|
||||
optionally uses info in old stream to keep this opening like the previous)
|
||||
|
||||
|
||||
(SETFILEINFO POINTER) (* (stream/name attribute newvalue device) sets attribute of
|
||||
open stream or closed file of given name)
|
||||
(TRUNCATEFILE POINTER) (* (stream page offset) make stream's eof be at page,offset,
|
||||
discarding anything after it)
|
||||
(WRITEPAGES POINTER) (* (stream firstpage# buflist) writes from buflist to stream
|
||||
starting at firstpage# of stream)
|
||||
(BIN POINTER) (* (stream) => next byte of input)
|
||||
(BOUT POINTER) (* (stream byte) output byte to stream)
|
||||
(PEEKBIN POINTER) (* (stream) => next byte without advancing position in stream)
|
||||
(READP POINTER) (* (stream flag) => T if there is input available from stream)
|
||||
(BACKFILEPTR POINTER) (* (stream) backs up "fileptr" by one.
|
||||
Stream is only required to be able to do this once, i.e.
|
||||
one-character buffer suffices)
|
||||
(DEVICEINFO POINTER) (* arbitrary device-specific info stored here)
|
||||
(FORCEOUTPUT POINTER) (* (stream waitForFinish) flushes out to device anything that
|
||||
is buffered awaiting transmission)
|
||||
(LASTC POINTER) (* Should be possible only if RANDOMACCESSP)
|
||||
(SETFILEPTR POINTER)
|
||||
(GETFILEPTR POINTER)
|
||||
(GETEOFPTR POINTER)
|
||||
(EOFP POINTER)
|
||||
(BLOCKIN POINTER) (* (stream buffer byteoffset nbytes))
|
||||
(BLOCKOUT POINTER) (* (stream buffer byteoffset nbytes))
|
||||
(RENAMEFILE POINTER) (* oldfile newfile device)
|
||||
(RELEASEBUFFER POINTER) (* (stream) => Does whatever appropriate when CBUFPTR is
|
||||
released)
|
||||
(GETNEXTBUFFER POINTER)
|
||||
|
||||
(* (stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next. whatfor is READ or WRITE.
|
||||
Can cause EOF error unless noerrorflg)
|
||||
|
||||
|
||||
(SETEOFPTR POINTER) (* (stream length) => truncates or lengthens stream to
|
||||
indicated length)
|
||||
(FREEPAGECOUNT POINTER) (* (host/dir dev) => # of free pages on host/dir)
|
||||
(MAKEDIRECTORY POINTER) (* (host/dir dev))
|
||||
(WINDOWOPS POINTER) (* window system operations -
|
||||
type WSOPS)
|
||||
(WINDOWDATA POINTER) (* data for window systems)
|
||||
(CHECKFILENAME POINTER) (* (name dev) => name if it is well-formed file name for dev)
|
||||
(HOSTALIVEP POINTER) (* (host dev) => true if host is alive, i.e., responsive;
|
||||
only defined if REMOTEP is true)
|
||||
(OPENP POINTER) (* (name access dev) => stream if name is open for access, or
|
||||
all open streams if name = NIL)
|
||||
(OPENFILELST POINTER) (* Default place to keep list of streams open on this device)
|
||||
(NIL POINTER) (* Spare)
|
||||
)
|
||||
DIRECTORYNAMEP _(FUNCTION NILL)
|
||||
HOSTNAMEP _(FUNCTION NILL)
|
||||
READP _(FUNCTION \GENERIC.READP)
|
||||
SETFILEPTR _(FUNCTION \IS.NOT.RANDACCESSP)
|
||||
GETFILEPTR _(FUNCTION \ILLEGAL.DEVICEOP)
|
||||
GETEOFPTR _(FUNCTION \IS.NOT.RANDACCESSP)
|
||||
EOFP _(FUNCTION \ILLEGAL.DEVICEOP)
|
||||
BLOCKIN _(FUNCTION \GENERIC.BINS)
|
||||
BLOCKOUT _(FUNCTION \GENERIC.BOUTS)
|
||||
RENAMEFILE _(FUNCTION \GENERIC.RENAMEFILE)
|
||||
FORCEOUTPUT _(FUNCTION NILL))
|
||||
]
|
||||
(/DECLAREDATATYPE (QUOTE FDEV)
|
||||
(QUOTE (POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG
|
||||
FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER
|
||||
POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER POINTER POINTER))
|
||||
(QUOTE ((FDEV 0 POINTER)
|
||||
(FDEV 0 (FLAGBITS . 0))
|
||||
(FDEV 0 (FLAGBITS . 16))
|
||||
(FDEV 0 (FLAGBITS . 32))
|
||||
(FDEV 0 (FLAGBITS . 48))
|
||||
(FDEV 0 (FLAGBITS . 64))
|
||||
(FDEV 0 (FLAGBITS . 80))
|
||||
(FDEV 0 (FLAGBITS . 96))
|
||||
(FDEV 0 (FLAGBITS . 112))
|
||||
(FDEV 2 (FLAGBITS . 0))
|
||||
(FDEV 2 (FLAGBITS . 16))
|
||||
(FDEV 2 (FLAGBITS . 32))
|
||||
(FDEV 2 (FLAGBITS . 48))
|
||||
(FDEV 2 (FLAGBITS . 64))
|
||||
(FDEV 2 (FLAGBITS . 80))
|
||||
(FDEV 2 (FLAGBITS . 96))
|
||||
(FDEV 2 (FLAGBITS . 112))
|
||||
(FDEV 2 POINTER)
|
||||
(FDEV 4 POINTER)
|
||||
(FDEV 6 POINTER)
|
||||
(FDEV 8 POINTER)
|
||||
(FDEV 10 POINTER)
|
||||
(FDEV 12 POINTER)
|
||||
(FDEV 14 POINTER)
|
||||
(FDEV 16 POINTER)
|
||||
(FDEV 18 POINTER)
|
||||
(FDEV 20 POINTER)
|
||||
(FDEV 22 POINTER)
|
||||
(FDEV 24 POINTER)
|
||||
(FDEV 26 POINTER)
|
||||
(FDEV 28 POINTER)
|
||||
(FDEV 30 POINTER)
|
||||
(FDEV 32 POINTER)
|
||||
(FDEV 34 POINTER)
|
||||
(FDEV 36 POINTER)
|
||||
(FDEV 38 POINTER)
|
||||
(FDEV 40 POINTER)
|
||||
(FDEV 42 POINTER)
|
||||
(FDEV 44 POINTER)
|
||||
(FDEV 46 POINTER)
|
||||
(FDEV 48 POINTER)
|
||||
(FDEV 50 POINTER)
|
||||
(FDEV 52 POINTER)
|
||||
(FDEV 54 POINTER)
|
||||
(FDEV 56 POINTER)
|
||||
(FDEV 58 POINTER)
|
||||
(FDEV 60 POINTER)
|
||||
(FDEV 62 POINTER)
|
||||
(FDEV 64 POINTER)
|
||||
(FDEV 66 POINTER)
|
||||
(FDEV 68 POINTER)
|
||||
(FDEV 70 POINTER)
|
||||
(FDEV 72 POINTER)
|
||||
(FDEV 74 POINTER)
|
||||
(FDEV 76 POINTER)
|
||||
(FDEV 78 POINTER)
|
||||
(FDEV 80 POINTER)
|
||||
(FDEV 82 POINTER)))
|
||||
(QUOTE 84))
|
||||
(DECLARE: EVAL@COMPILE
|
||||
[PUTPROPS .APPLY. MACRO ((U V)
|
||||
(* body for APPLY, used by RETAPPLY too)
|
||||
(PROG ((DEF U))
|
||||
LP
|
||||
[COND ((LITATOM DEF)
|
||||
(COND ((NOT (fetch (LITATOM CCODEP)
|
||||
of DEF))
|
||||
(* EXPR)
|
||||
(SETQ DEF (fetch (LITATOM DEFPOINTER)
|
||||
of DEF)))
|
||||
((EQ (fetch (LITATOM ARGTYPE)
|
||||
of DEF)
|
||||
3)
|
||||
(GO NLSTAR))
|
||||
(T (GO NORMAL]
|
||||
[COND ((LISTP DEF)
|
||||
(SELECTQ (CAR DEF)
|
||||
[NLAMBDA (AND (NLISTP (CADR DEF))
|
||||
(CADR DEF)
|
||||
(GO NLSTAR]
|
||||
(FUNARG (SETQ DEF (CADR DEF))
|
||||
(GO LP))
|
||||
NIL))
|
||||
((NULL DEF)
|
||||
(RETURN (FAULTAPPLY U V]
|
||||
NORMAL
|
||||
(RETURN (SPREADAPPLY U V))
|
||||
NLSTAR
|
||||
(* NLAMBDA*)
|
||||
(RETURN (SPREADAPPLY* U V]
|
||||
[PUTPROPS FDEVOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*)
|
||||
(CONS (COND ((EQ (CAR (LISTP (CAR ARGS)))
|
||||
(QUOTE QUOTE))
|
||||
(LIST (QUOTE fetch)
|
||||
(CADAR ARGS)
|
||||
(QUOTE of)
|
||||
(CADR ARGS)))
|
||||
(T (HELP "FDEVOP - OPNAME not quoted:"
|
||||
ARGS)))
|
||||
(CDDR ARGS]
|
||||
)
|
||||
(MOVD (QUOTE APPLY*)
|
||||
(QUOTE SPREADAPPLY*))
|
||||
(PUTPROPS FDEVTEST COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
1
internal/test/tools/FDEVTEST.LCOM
Normal file
1
internal/test/tools/FDEVTEST.LCOM
Normal file
File diff suppressed because one or more lines are too long
345
internal/test/tools/FILEBANGER
Normal file
345
internal/test/tools/FILEBANGER
Normal file
@@ -0,0 +1,345 @@
|
||||
(FILECREATED "13-Sep-85 14:27:55" {ERINYES}<TEST>TOOLS>FILEBANGER.;2 12693
|
||||
|
||||
changes to: (FNS FILEBANGER)
|
||||
|
||||
previous date: "14-AUG-83 13:56:54" {ERINYES}<TEST>TOOLS>FILEBANGER.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1983, 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT FILEBANGERCOMS)
|
||||
|
||||
(RPAQQ FILEBANGERCOMS ((FNS DOFILEBANGER DOMAKEFILEBANGER DOZEROBANGER FILEBANGER
|
||||
FBCOPYBYTES FBMAKETESTFILE MAKEBANGERWINDOW MAKEFILEBANGER
|
||||
ZEROBANGER SUSPEND.FILEBANGER WATCHDISKPAGES)
|
||||
(FNS BINCOM)
|
||||
(FNS CHECKFORZEROS)
|
||||
(INITVARS (FBREPEATCOUNT 4)
|
||||
(FILEBANGERS))))
|
||||
(DEFINEQ
|
||||
|
||||
(DOFILEBANGER
|
||||
[LAMBDA (DESTINATION LENGTH NOBREAK) (* bvm: "10-AUG-83 17:37")
|
||||
(push FILEBANGERS (ADD.PROCESS (BQUOTE (FILEBANGER (QUOTE , LENGTH)
|
||||
(QUOTE , DESTINATION)
|
||||
T
|
||||
(QUOTE , NOBREAK])
|
||||
|
||||
(DOMAKEFILEBANGER
|
||||
[LAMBDA (SOURCE) (* bvm: "14-AUG-83 13:53")
|
||||
(push FILEBANGERS (ADD.PROCESS (BQUOTE (MAKEFILEBANGER (QUOTE , SOURCE])
|
||||
|
||||
(DOZEROBANGER
|
||||
[LAMBDA (TESTFILE1 TESTFILE2 TMPFILENAME) (* bvm: "14-AUG-83 13:54")
|
||||
(push FILEBANGERS (ADD.PROCESS (BQUOTE (ZEROBANGER (QUOTE , TESTFILE1)
|
||||
(QUOTE , TESTFILE2)
|
||||
(QUOTE , TMPFILENAME])
|
||||
|
||||
(FILEBANGER
|
||||
[LAMBDA (TESTFILE DESTINATION MAKEWINDOW NOBREAK INPARMS OUTPARMS)
|
||||
(* mbb "13-Sep-85 14:26")
|
||||
(DECLARE (SPECVARS ERRCNT LOOPCNT))
|
||||
(RESETLST (PROG ((ERRCNT 0)
|
||||
(LOOPCNT 0)
|
||||
(OPTION (AND (NOT NOBREAK)
|
||||
(QUOTE BREAK)))
|
||||
MYFILE NEWFILE LASTFILE TMPFILENAME OUTPUTSTREAM)
|
||||
[COND
|
||||
[(OR (NULL TESTFILE)
|
||||
(FIXP TESTFILE))
|
||||
(SETQ TESTFILE (SETQ MYFILE (FBMAKETESTFILE
|
||||
TESTFILE
|
||||
(PACKFILENAME (QUOTE EXTENSION)
|
||||
(QUOTE SOURCE)
|
||||
(QUOTE BODY)
|
||||
(OR DESTINATION (QUOTE FILEBANGER]
|
||||
(T (CLOSEF (SETQ TESTFILE (OPENFILE (OR TESTFILE (RETURN
|
||||
"No TESTFILE supplied"))
|
||||
(QUOTE INPUT]
|
||||
[COND
|
||||
[MAKEWINDOW (SETQ OUTPUTSTREAM (GETSTREAM (MAKEBANGERWINDOW
|
||||
TESTFILE
|
||||
"File Banger")
|
||||
(QUOTE OUTPUT]
|
||||
(T (SETQ OUTPUTSTREAM (GETSTREAM T (QUOTE OUTPUT]
|
||||
(COND
|
||||
((NOT MYFILE)
|
||||
(SETQ MYFILE (COPYFILE TESTFILE (PACKFILENAME (QUOTE EXTENSION)
|
||||
(QUOTE FBTESTER)
|
||||
(QUOTE VERSION)
|
||||
NIL
|
||||
(QUOTE BODY)
|
||||
TESTFILE)))
|
||||
(BINCOM MYFILE TESTFILE OPTION OUTPUTSTREAM)))
|
||||
[SETQ TMPFILENAME (OR DESTINATION (PACKFILENAME (QUOTE EXTENSION)
|
||||
(QUOTE FBTEMP)
|
||||
(QUOTE VERSION)
|
||||
NIL
|
||||
(QUOTE BODY)
|
||||
(OR MYFILE
|
||||
(QUOTE FILEBANGER]
|
||||
LP (PRIN1 (add LOOPCNT 1)
|
||||
OUTPUTSTREAM)
|
||||
(RESETLST [RESETSAVE (SETQ NEWFILE (OPENFILE TMPFILENAME
|
||||
(QUOTE OUTPUT)
|
||||
NIL NIL OUTPARMS))
|
||||
(QUOTE (PROGN (CLOSEF OLDVALUE]
|
||||
[RESETSAVE (OPENFILE MYFILE (QUOTE INPUT)
|
||||
NIL NIL INPARMS)
|
||||
(QUOTE (PROGN (CLOSEF OLDVALUE]
|
||||
(COPYBYTES MYFILE NEWFILE))
|
||||
(AND LASTFILE (DELFILE LASTFILE))
|
||||
[COND
|
||||
((NULL (MEMB MYFILE (DIRECTORY DESTINATION)))
|
||||
(add ERRCNT 1)
|
||||
(COND
|
||||
((NEQ OPTION (QUOTE NOMSG))
|
||||
(printout OUTPUTSTREAM T MYFILE
|
||||
" not found in directory enumeration.")
|
||||
(TERPRI T)))
|
||||
(COND
|
||||
((EQ OPTION (QUOTE BREAK))
|
||||
(HELP MYFILE]
|
||||
[RPTQ FBREPEATCOUNT (PROGN (PRIN1 (QUOTE %.)
|
||||
OUTPUTSTREAM)
|
||||
(COND
|
||||
((NEQ (BINCOM MYFILE NEWFILE OPTION
|
||||
OUTPUTSTREAM)
|
||||
T)
|
||||
(add ERRCNT 1]
|
||||
(SETQ LASTFILE NEWFILE)
|
||||
(GO LP])
|
||||
|
||||
(FBCOPYBYTES
|
||||
[LAMBDA (INSTREAM ECHOSTREAM START) (* bvm: "24-JUN-83 19:00")
|
||||
(SETFILEPTR INSTREAM START)
|
||||
(RPTQ 40 (\OUTCHAR ECHOSTREAM (\BIN INSTREAM])
|
||||
|
||||
(FBMAKETESTFILE
|
||||
[LAMBDA (LENGTH NAME) (* bvm: "10-AUG-83 17:47")
|
||||
(RESETLST (PROG [(FILE (OPENFILE (OR NAME (QUOTE FILEBANGER.TMP))
|
||||
(QUOTE OUTPUT)
|
||||
(QUOTE NEW]
|
||||
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
|
||||
FILE))
|
||||
(for I from 1 to (OR LENGTH 1000) bind (STREAM _(GETSTREAM
|
||||
FILE
|
||||
(QUOTE OUTPUT)))
|
||||
do (\OUTCHAR STREAM (RAND 32 127)))
|
||||
(RETURN FILE])
|
||||
|
||||
(MAKEBANGERWINDOW
|
||||
[LAMBDA (FILE TYPE) (* bvm: "12-AUG-83 13:06")
|
||||
(PROG (W)
|
||||
[RESETSAVE (TTYDISPLAYSTREAM (SETQ W (CREATEW NIL (CONCAT TYPE " for " FILE]
|
||||
(DSPFONT (QUOTE (GACHA 8))
|
||||
W)
|
||||
[WINDOWPROP W (QUOTE CLOSEFN)
|
||||
(FUNCTION (LAMBDA (W P)
|
||||
(AND [PROCESSP (SETQ P (WINDOWPROP W (QUOTE PROCESS]
|
||||
(PROCESS.EVAL P (QUOTE (ERROR!]
|
||||
(WINDOWPROP W (QUOTE PAGEFULLFN)
|
||||
(FUNCTION NILL))
|
||||
(RETURN W])
|
||||
|
||||
(MAKEFILEBANGER
|
||||
[LAMBDA (TESTFILE) (* bvm: "14-AUG-83 13:56")
|
||||
(DECLARE (SPECVARS ERRCNT LOOPCNT))
|
||||
(RESETLST (PROG ((LOOPCNT 0)
|
||||
NEWFILE LASTFILE)
|
||||
[SETQ TESTFILE (LOADFROM (OR TESTFILE (RETURN "No TESTFILE supplied"]
|
||||
(MAKEBANGERWINDOW TESTFILE "MAKEFILE Banger")
|
||||
(SETQ TESTFILE (NAMEFIELD TESTFILE T))
|
||||
LP (SETQ NEWFILE (MAKEFILE TESTFILE))
|
||||
(AND (CHECKFORZEROS NEWFILE)
|
||||
(HELP "Zeros found"))
|
||||
[COND
|
||||
(LASTFILE (DELFILE LASTFILE)
|
||||
(REMPROP LASTFILE (QUOTE PAGES]
|
||||
(SETQ LASTFILE NEWFILE)
|
||||
(GO LP])
|
||||
|
||||
(ZEROBANGER
|
||||
[LAMBDA (TESTFILE1 TESTFILE2 TMPFILENAME N NOBREAK OUTPUTSTREAM)
|
||||
(* bvm: "12-AUG-83 13:07")
|
||||
(DECLARE (SPECVARS ERRCNT LOOPCNT))
|
||||
(RESETLST (PROG ((ERRCNT 0)
|
||||
(LOOPCNT 0)
|
||||
(OPTION (AND (NOT NOBREAK)
|
||||
(QUOTE BREAK)))
|
||||
THISFILE NEWFILE LASTFILE)
|
||||
[SETQ THISFILE (CLOSEF (SETQ TESTFILE1 (OPENFILE (OR TESTFILE1
|
||||
(RETURN
|
||||
"No TESTFILE supplied"))
|
||||
(QUOTE INPUT]
|
||||
(RESETSAVE NIL (LIST (QUOTE CLOSEF?)
|
||||
TESTFILE1))
|
||||
[CLOSEF (SETQ TESTFILE2 (OPENFILE (OR TESTFILE2 (RETURN
|
||||
"No TESTFILE supplied"))
|
||||
(QUOTE INPUT]
|
||||
(RESETSAVE NIL (LIST (QUOTE CLOSEF?)
|
||||
TESTFILE2))
|
||||
[CLOSEF (SETQ TMPFILENAME (OPENFILE (OR TMPFILENAME (QUOTE
|
||||
ZEROBANGER.TMP))
|
||||
(QUOTE OUTPUT]
|
||||
(RESETSAVE NIL (LIST (QUOTE CLOSEF?)
|
||||
TMPFILENAME))
|
||||
(SETQ OUTPUTSTREAM (GETSTREAM (OR OUTPUTSTREAM (MAKEBANGERWINDOW
|
||||
THISFILE "Zero Banger"))
|
||||
(QUOTE OUTPUT)))
|
||||
LP (COND
|
||||
((AND N (ILESSP (add N -1)
|
||||
0))
|
||||
(RETURN ERRCNT)))
|
||||
(printout OUTPUTSTREAM (add LOOPCNT 1)
|
||||
,)
|
||||
(OPENFILE TMPFILENAME (QUOTE BOTH)
|
||||
(QUOTE OLD))
|
||||
(OPENFILE THISFILE (QUOTE INPUT))
|
||||
(COPYBYTES THISFILE TMPFILENAME 0 -1)
|
||||
(CLOSEF THISFILE)
|
||||
(SETFILEINFO TMPFILENAME (QUOTE LENGTH)
|
||||
(GETFILEPTR TMPFILENAME))
|
||||
(CLOSEF TMPFILENAME) (* (AND LASTFILE (DELFILE LASTFILE)))
|
||||
(COND
|
||||
((NEQ (BINCOM THISFILE TMPFILENAME OPTION OUTPUTSTREAM)
|
||||
T)
|
||||
(add ERRCNT 1))) (* (SETQ LASTFILE NEWFILE))
|
||||
(SETQ THISFILE (COND
|
||||
((EQ THISFILE TESTFILE1)
|
||||
TESTFILE2)
|
||||
(T TESTFILE1)))
|
||||
(GO LP])
|
||||
|
||||
(SUSPEND.FILEBANGER
|
||||
[LAMBDA NIL (* bvm: "10-AUG-83 17:39")
|
||||
(for PROC in FILEBANGERS when (AND (PROCESSP PROC)
|
||||
(NEQ PROC (THIS.PROCESS)))
|
||||
do (SUSPEND.PROCESS PROC))
|
||||
(CLOSEF (PROG1 PUPTRACEFILE (SETQ PUPTRACEFILE (PUPTRACE PUPTRACEFLG
|
||||
(QUOTE (832 416 190 336])
|
||||
|
||||
(WATCHDISKPAGES
|
||||
[LAMBDA (THRESHOLD) (* bvm: "10-AUG-83 17:11")
|
||||
(OR THRESHOLD (SETQ THRESHOLD 2000))
|
||||
(while T bind (MARGIN _ THRESHOLD)
|
||||
LASTFILE
|
||||
do (COND
|
||||
((ILESSP (DISKFREEPAGES)
|
||||
(IPLUS THRESHOLD MARGIN))
|
||||
(COND
|
||||
(LASTFILE (DELFILE LASTFILE)))
|
||||
(SETQ LASTFILE (CLOSEF PUPTRACEFILE))
|
||||
(SETQ PUPTRACEFILE (OPENFILE (QUOTE {DSK}PUPTRACE.TMP)
|
||||
(QUOTE OUTPUT)
|
||||
(QUOTE NEW)))
|
||||
(SETQ MARGIN 0)))
|
||||
(BLOCK 60000])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(BINCOM
|
||||
[LAMBDA (FILE1 FILE2 OPTION OUTPUTSTREAM) (* bvm: "24-JUN-83 18:45")
|
||||
(RESETLST (PROG ((STRM1 (OPENSTREAM FILE1 (QUOTE INPUT)
|
||||
(QUOTE OLD)))
|
||||
(STRM2 (OPENSTREAM FILE2 (QUOTE INPUT)
|
||||
(QUOTE OLD)))
|
||||
HERE B1 B2)
|
||||
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
|
||||
STRM1))
|
||||
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
|
||||
STRM2))
|
||||
(SETQ OUTPUTSTREAM (GETSTREAM (OR OUTPUTSTREAM T)
|
||||
(QUOTE OUTPUT)))
|
||||
(RETURN (COND
|
||||
((IEQP (GETEOFPTR STRM1)
|
||||
(GETEOFPTR STRM2))
|
||||
(for I from 1 to (GETEOFPTR STRM1)
|
||||
do (COND
|
||||
((NEQ (SETQ B1 (\BIN STRM1))
|
||||
(SETQ B2 (\BIN STRM2)))
|
||||
(COND
|
||||
((NEQ OPTION (QUOTE NOMSG))
|
||||
(printout OUTPUTSTREAM T (FULLNAME STRM1)
|
||||
" and "
|
||||
(FULLNAME STRM2)
|
||||
" differ at byte " .P2
|
||||
(SETQ HERE (SUB1 (GETFILEPTR
|
||||
STRM1)))
|
||||
" (page " .P2
|
||||
(fetch (BYTEPTR PAGE)
|
||||
of HERE)
|
||||
", byte " .P2
|
||||
(fetch (BYTEPTR OFFSET)
|
||||
of HERE)
|
||||
"): ")
|
||||
(\OUTCHAR OUTPUTSTREAM B1)
|
||||
(printout OUTPUTSTREAM "[" .P2 B1 "] vs. ")
|
||||
(\OUTCHAR OUTPUTSTREAM B2)
|
||||
(printout OUTPUTSTREAM "[" .P2 B2 "]" T
|
||||
(FULLNAME STRM1)
|
||||
" reads:" T)
|
||||
(FBCOPYBYTES STRM1 OUTPUTSTREAM HERE)
|
||||
(printout OUTPUTSTREAM T (FULLNAME STRM2)
|
||||
" reads:" T)
|
||||
(FBCOPYBYTES STRM2 OUTPUTSTREAM HERE)
|
||||
(TERPRI T)))
|
||||
(COND
|
||||
((EQ OPTION (QUOTE BREAK))
|
||||
(HELP STRM1 STRM2)))
|
||||
(RETURN I)))
|
||||
finally (RETURN T)))
|
||||
(T (COND
|
||||
((NEQ OPTION (QUOTE NOMSG))
|
||||
(printout OUTPUTSTREAM T (FULLNAME STRM1)
|
||||
" has length " .P2 (GETEOFPTR STRM1)
|
||||
", but "
|
||||
(FULLNAME STRM2)
|
||||
" has length " .P2 (GETEOFPTR STRM2)
|
||||
T)))
|
||||
(COND
|
||||
((EQ OPTION (QUOTE BREAK))
|
||||
(HELP STRM1 STRM2)))
|
||||
(LIST (GETEOFPTR STRM1)
|
||||
(GETEOFPTR STRM2])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(CHECKFORZEROS
|
||||
[LAMBDA (FILE MINZEROS) (* bvm: " 9-AUG-83 16:14")
|
||||
(RESETLST (PROG ((STREAM (OPENSTREAM FILE (QUOTE INPUT)))
|
||||
(#FAILURES 0)
|
||||
N)
|
||||
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
|
||||
STREAM))
|
||||
(OR MINZEROS (SETQ MINZEROS 20))
|
||||
(replace ENDOFSTREAMOP of STREAM with (FUNCTION NILL))
|
||||
(printout T (FULLNAME STREAM)
|
||||
": " T)
|
||||
(do (SELECTQ (BIN STREAM)
|
||||
(NIL (RETURN))
|
||||
[0 (SETQ N 1)
|
||||
(while (ZEROP (BIN STREAM)) do (add N 1))
|
||||
(COND
|
||||
((IGREATERP N MINZEROS)
|
||||
(printout T .P2 N " zeros starting at byte " .P2
|
||||
(SUB1 (IDIFFERENCE (GETFILEPTR STREAM)
|
||||
N))
|
||||
T)
|
||||
(add #FAILURES 1]
|
||||
NIL))
|
||||
(RETURN (AND (NOT (ZEROP #FAILURES))
|
||||
#FAILURES])
|
||||
)
|
||||
|
||||
(RPAQ? FBREPEATCOUNT 4)
|
||||
|
||||
(RPAQ? FILEBANGERS )
|
||||
(PUTPROPS FILEBANGER COPYRIGHT ("Xerox Corporation" 1983 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (624 9302 (DOFILEBANGER 634 . 918) (DOMAKEFILEBANGER 920 . 1123) (
|
||||
DOZEROBANGER 1125 . 1399) (FILEBANGER 1401 . 4197) (FBCOPYBYTES 4199 . 4399) (
|
||||
FBMAKETESTFILE 4401 . 4942) (MAKEBANGERWINDOW 4944 . 5550) (MAKEFILEBANGER 5552 . 6247) (
|
||||
ZEROBANGER 6249 . 8297) (SUSPEND.FILEBANGER 8299 . 8701) (WATCHDISKPAGES 8703 . 9300)) (
|
||||
9303 11605 (BINCOM 9313 . 11603)) (11606 12552 (CHECKFORZEROS 11616 . 12550)))))
|
||||
STOP
|
||||
2
internal/test/tools/LOCK-FILE
Normal file
2
internal/test/tools/LOCK-FILE
Normal file
@@ -0,0 +1,2 @@
|
||||
((rhoades.pa 1 3) (Markovitch.pa 14 22 DATABASE 4 16))6 14 27 26 25 24 23 20 18 13 12 11 9 4 10 8 7 6
|
||||
5))
|
||||
1
internal/test/tools/NEXTID
Normal file
1
internal/test/tools/NEXTID
Normal file
@@ -0,0 +1 @@
|
||||
28
|
||||
158
internal/test/tools/RANDOM-GENERATOR
Normal file
158
internal/test/tools/RANDOM-GENERATOR
Normal file
@@ -0,0 +1,158 @@
|
||||
(FILECREATED "24-Jul-85 17:42:37" {DSK}<LISPFILES>TESTER>SOURCES>RANDOM-GENERATOR.;2 7172
|
||||
|
||||
changes to: (FNS TEST.GENERATE-RANDOM)
|
||||
|
||||
previous date: "19-Jul-85 11:24:20" {DSK}<LISPFILES>TESTER>SOURCES>RANDOM-GENERATOR.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT RANDOM-GENERATORCOMS)
|
||||
|
||||
(RPAQQ RANDOM-GENERATORCOMS ((FNS TEST.GENERATE-RANDOM TEST.GENERATE-LIST-OF-ITEMS
|
||||
TEST.RANDOM-SELECTION)
|
||||
(INITVARS (TEST.TYPES-OF-RANDOM-OBJECTS (QUOTE (INTEGER
|
||||
SHORT-SIMPLE-LIST
|
||||
SHORT-LIST
|
||||
CHARACTER)))
|
||||
(TEST.MIN-INTEGER MIN.FIXP)
|
||||
(TEST.MAX-INTEGER MAX.FIXP)
|
||||
(TEST.VERY-SMALL 4)
|
||||
(TEST.SMALLP MAX.SMALLP)
|
||||
(TEST.SMALL 1000)
|
||||
(TEST.LARGE (IDIFFERENCE MAX.FIXP 1000))
|
||||
(TEST.MAX-DEPTH 4)
|
||||
(TEST.MAX-CHARACTER-CODE 255))))
|
||||
(DEFINEQ
|
||||
|
||||
(TEST.GENERATE-RANDOM
|
||||
[LAMBDA (OBJECT-SPECIFICATIONS) (* sm "24-Jul-85 15:57")
|
||||
(SELECTQ (if (LISTP OBJECT-SPECIFICATIONS)
|
||||
then (CAR OBJECT-SPECIFICATIONS)
|
||||
else OBJECT-SPECIFICATIONS)
|
||||
(INTEGER (RAND TEST.MIN-INTEGER TEST.MAX-INTEGER))
|
||||
[SPECIAL-INTEGER (TEST.RANDOM-SELECTION (QUOTE (0 1 -1]
|
||||
(BOUND-INTEGER (RAND (CADR OBJECT-SPECIFICATIONS)
|
||||
(CADDR OBJECT-SPECIFICATIONS)))
|
||||
[LARGE-INTEGER (TEST.RANDOM-SELECTION (LIST (RAND (IMINUS TEST.LARGE)
|
||||
TEST.MIN-INTEGER)
|
||||
(RAND TEST.LARGE TEST.MAX-INTEGER]
|
||||
[SMALL-INTEGER (TEST.RANDOM-SELECTION (LIST (RAND (IMINUS TEST.SMALL)
|
||||
0)
|
||||
(RAND 0 TEST.SMALL]
|
||||
(SMALL-POSITIVE-INTEGER (RAND 1 TEST.SMALL))
|
||||
(SMALL-NON-NEGATIVE-INTEGER (RAND 0 TEST.SMALL))
|
||||
(SMALL-NEGATIVE-INTEGER (RAND (IMINUS TEST.SMALL)
|
||||
-1))
|
||||
(SMALL-NON-POSITIVE-INTEGER (RAND (IMINUS TEST.SMALL)
|
||||
0))
|
||||
(VERY-SMALL-POSITIVE-INTEGER (RAND 1 TEST.VERY-SMALL))
|
||||
(VERY-SMALL-NON-NEGATIVE-INTEGER (RAND 0 TEST.VERY-SMALL))
|
||||
(VERY-SMALL-NEGATIVE-INTEGER (RAND (IMINUS TEST.VERY-SMALL)
|
||||
-1))
|
||||
(VERY-SMALL-NON-POSITIVE-INTEGER (RAND (IMINUS TEST.VERY-SMALL)
|
||||
0))
|
||||
(VERY-LARGE-POSITIVE-INTEGER (RAND (IDIFFERENCE TEST.MAX-INTEGER 1000)
|
||||
TEST.MAX-INTEGER))
|
||||
(VERY-LARGE-NEGATIVE-INTEGER (RAND TEST.MIN-INTEGER (IDIFFERENCE TEST.MIN-INTEGER 1000)))
|
||||
(POSITIVE-INTEGER (RAND 1 TEST.MAX-INTEGER))
|
||||
(NON-NEGATIVE-INTEGER (RAND 0 TEST.MAX-INTEGER))
|
||||
(NEGATIVE-INTEGER (RAND TEST.MIN-INTEGER -1))
|
||||
(NON-POSITIVE-INTEGER (RAND TEST.MIN-INTEGER 0))
|
||||
[BIGNUM (PACK (CONS (TEST.RANDOM-SELECTION (QUOTE (- "")))
|
||||
(CONS (RAND 0 9)
|
||||
(for I from 1 to (RAND 20 99) collect (RAND 0 9]
|
||||
[POSITIVE-BIGNUM (PACK (CONS (RAND 0 9)
|
||||
(for I from 1 to (RAND 20 99) collect (RAND 0 9]
|
||||
[SPECIAL-BIGNUM (TEST.RANDOM-SELECTION (QUOTE (16383 16382 16384 32767 32766 32768 65535
|
||||
65534 65536 16777215 16777214
|
||||
16777216 134217727 134217726
|
||||
134217728]
|
||||
[POSITIVE-POWEROF10-BIGNUM (PACK (CONS 1 (for I from 1 to (RAND 20 99) collect 0]
|
||||
(WINDOW (CREATEW (TEST.GENERATE-RANDOM (QUOTE REGION))
|
||||
(TEST.RANDOM-SELECTION (LIST NIL "DUMMY"))
|
||||
(RAND 0 20)))
|
||||
[REGION (PROG (LEFT BOTTOM)
|
||||
(SETQ LEFT (RAND 0 SCREENWIDTH))
|
||||
(SETQ BOTTOM (RAND 0 SCREENHEIGHT))
|
||||
(RETURN (CREATEREGION LEFT BOTTOM (RAND 10 (IDIFFERENCE SCREENWIDTH LEFT))
|
||||
(RAND 10 (IDIFFERENCE SCREENHEIGHT BOTTOM]
|
||||
(LIST-OF-ITEMS (TEST.GENERATE-LIST-OF-ITEMS (if (LISTP OBJECT-SPECIFICATIONS)
|
||||
then (CDR OBJECT-SPECIFICATIONS)
|
||||
else NIL)))
|
||||
(SHORT-SIMPLE-LIST (for I from 1 to (TEST.GENERATE-RANDOM (QUOTE
|
||||
VERY-SMALL-NON-NEGATIVE-INTEGER))
|
||||
collect (PACK* (QUOTE A)
|
||||
I)))
|
||||
(SHORT-SIMPLE-NON-NULL-LIST (for I from 1 to (TEST.GENERATE-RANDOM (QUOTE
|
||||
VERY-SMALL-POSITIVE-INTEGER))
|
||||
collect (PACK* (QUOTE A)
|
||||
I)))
|
||||
[SHORT-LIST (PROG (DEPTH)
|
||||
(SETQ DEPTH (if (AND OBJECT-SPECIFICATIONS (LISTP
|
||||
OBJECT-SPECIFICATIONS))
|
||||
then (CADR OBJECT-SPECIFICATIONS)
|
||||
else TEST.MAX-DEPTH))
|
||||
(if (EQ DEPTH 1)
|
||||
then (RETURN (TEST.GENERATE-RANDOM (QUOTE SHORT-SIMPLE-LIST)))
|
||||
else (RETURN (for I from 1 to (TEST.GENERATE-RANDOM (QUOTE
|
||||
VERY-SMALL-NON-NEGATIVE-INTEGER))
|
||||
collect (TEST.GENERATE-RANDOM
|
||||
(LIST (QUOTE SHORT-LIST)
|
||||
(RAND 1 (SUB1 DEPTH]
|
||||
[LIST-OF-CHARACTERS (PROG (NUM-OF-CHARACTERS)
|
||||
[SETQ NUM-OF-CHARACTERS (if (AND OBJECT-SPECIFICATIONS
|
||||
(LISTP OBJECT-SPECIFICATIONS))
|
||||
then (CADR OBJECT-SPECIFICATIONS)
|
||||
else (TEST.GENERATE-RANDOM
|
||||
(QUOTE LARGE-POSITIVE-INTEGER]
|
||||
(RETURN (for I from 1 to NUM-OF-CHARACTERS
|
||||
collect (TEST.GENERATE-RANDOM (QUOTE CHARACTER]
|
||||
(CHARACTER (CHARACTER (RAND 0 TEST.MAX-CHARACTER-CODE)))
|
||||
(PRINTOUT T OBJECT-TYPE " CAN NOT BE GENERATED."])
|
||||
|
||||
(TEST.GENERATE-LIST-OF-ITEMS
|
||||
[LAMBDA (SPEC-LIST) (* sm "17-Jun-85 00:27")
|
||||
(PROG (ITEM-TYPE MIN-ITEMS MAX-ITEMS)
|
||||
(SETQ ITEM-TYPE (if SPEC-LIST
|
||||
then (if (LISTP (CAR SPEC-LIST))
|
||||
then (CAR SPEC-LIST)
|
||||
else (LIST (CAR SPEC-LIST)))
|
||||
else TEST.TYPES-OF-RANDOM-OBJECTS))
|
||||
(SETQ MIN-ITEMS (if (CDR SPEC-LIST)
|
||||
then (CADR SPEC-LIST)
|
||||
else 0))
|
||||
(SETQ MAX-ITEMS (if (CDDR SPEC-LIST)
|
||||
then (CADDR SPEC-LIST)
|
||||
else (RAND 0 20)))
|
||||
(RETURN (for I from 1 to (RAND MIN-ITEMS MAX-ITEMS) collect (TEST.GENERATE-RANDOM
|
||||
(TEST.RANDOM-SELECTION
|
||||
ITEM-TYPE])
|
||||
|
||||
(TEST.RANDOM-SELECTION
|
||||
[LAMBDA (L) (* sm "15-Jun-85 17:30")
|
||||
(CAR (NTH L (RAND 1 (LENGTH L])
|
||||
)
|
||||
|
||||
(RPAQ? TEST.TYPES-OF-RANDOM-OBJECTS (QUOTE (INTEGER SHORT-SIMPLE-LIST SHORT-LIST CHARACTER)))
|
||||
|
||||
(RPAQ? TEST.MIN-INTEGER MIN.FIXP)
|
||||
|
||||
(RPAQ? TEST.MAX-INTEGER MAX.FIXP)
|
||||
|
||||
(RPAQ? TEST.VERY-SMALL 4)
|
||||
|
||||
(RPAQ? TEST.SMALLP MAX.SMALLP)
|
||||
|
||||
(RPAQ? TEST.SMALL 1000)
|
||||
|
||||
(RPAQ? TEST.LARGE (IDIFFERENCE MAX.FIXP 1000))
|
||||
|
||||
(RPAQ? TEST.MAX-DEPTH 4)
|
||||
|
||||
(RPAQ? TEST.MAX-CHARACTER-CODE 255)
|
||||
(PUTPROPS RANDOM-GENERATOR COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (915 6689 (TEST.GENERATE-RANDOM 925 . 5674) (TEST.GENERATE-LIST-OF-ITEMS 5676 . 6517) (
|
||||
TEST.RANDOM-SELECTION 6519 . 6687)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/RANDOM-GENERATOR.LCOM
Normal file
BIN
internal/test/tools/RANDOM-GENERATOR.LCOM
Normal file
Binary file not shown.
946
internal/test/tools/SLOOP.LISP
Normal file
946
internal/test/tools/SLOOP.LISP
Normal file
@@ -0,0 +1,946 @@
|
||||
;;; -*- Mode:LISP; Package: SLOOP; Syntax:COMMON-LISP; Base:10 -*- ;;;;;;;;
|
||||
;;; ;;;;;
|
||||
;;; Copyright (c) 1985,86 by William Schelter, ;;;;;
|
||||
;;; All rights reserved ;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;Report bugs to atp.schelter@r20.utexas.edu
|
||||
;;It comes with ABSOLUTELY NO WARRANTY but we hope it is useful.
|
||||
|
||||
|
||||
;;The following code is meant to run in COMMON LISP and to provide
|
||||
;;extensive iteration facilities, with very high backwards compatibility
|
||||
;;with the traditional loop macro. It is meant to be publicly available!
|
||||
;;Anyone is hereby given permission to copy it provided he does not make
|
||||
;;ANY changes to the file unless he is William Schelter. He may change
|
||||
;;the behavior after loading it by resetting the global variables such
|
||||
;;as like *Use-locatives*, *automatic-declarations*,.. listed at the
|
||||
;;beginning of this file. The original of this file is on
|
||||
;;r20.utexas.edu:<atp.schelter>sloop.lisp I am happy to accept suggestions
|
||||
;;for different defaults for various implementations, or for improvements.
|
||||
|
||||
;;If you want to redefine the common lisp loop you may include in your code:
|
||||
;;(defmacro loop (&body body)
|
||||
;; (parse-loop body))
|
||||
|
||||
;; Principal New Features
|
||||
|
||||
;;Sloop is extremely user extensible so that you may easily redefine most
|
||||
;;behavior, or add additional collections, and paths. There are a number
|
||||
;;of such examples defined in this file, including such constructs as
|
||||
;;"for V in-fringe X", "sum V", "averaging V", "for SYM in-package Y",
|
||||
;;"collate V" (for collecting X into an ordered list), "for (ELT I) in-array AR",
|
||||
;;"for (KEY ELT) in-table FOO" (if foo is a hash table). And of course
|
||||
;;you can combine any collection method with any path.
|
||||
;;Also there is iteration over products so that you may write
|
||||
;;(sloop for I below K
|
||||
;; sloop (for J below I
|
||||
;; collecting (foo I J)))
|
||||
;;Declare is fully supported. The syntax would be
|
||||
;;(sloop for u in l with v = 0
|
||||
;; declare (fixnum u v)
|
||||
;; do ....
|
||||
|
||||
;;This extensibility is gained by the ability to define a "loop-macro",
|
||||
;;which plays a role analagous to an ordiary lisp macro. See eg.
|
||||
;;definitions near that of "averaging". Essentially a "loop-macro"
|
||||
;;takes some arguments (supplied from the body of the loop following its
|
||||
;;occurrence, and returns a new form to be stuffed onto the front of the
|
||||
;;loop form, in place of it and its arguments).
|
||||
|
||||
;;Compile notes:
|
||||
;;For dec-20 clisp load the lisp file before compiling.
|
||||
|
||||
|
||||
;;there seems to be no unanimity about what in-package etc. does on loading
|
||||
;;and compiling a file. The following is as close to the examples in
|
||||
;;the Common Lisp manual, as we could make it.
|
||||
;;The user should put (require "SLOOP") and then (use-package "SLOOP")
|
||||
;;early in his init file. Note use of the string to avoid interning 'sloop
|
||||
;;in some other package.
|
||||
|
||||
(provide "SLOOP")
|
||||
|
||||
(in-package "SLOOP" :use '(LISP))
|
||||
|
||||
(export '(loop-return sloop def-loop-collect def-loop-map
|
||||
def-loop-for def-loop-macro local-finish
|
||||
#-lispm loop-finish) (find-package "SLOOP"))
|
||||
|
||||
|
||||
;;some variables that may be changed to suit different implementations:
|
||||
|
||||
(eval-when (compile load eval)
|
||||
|
||||
(defparameter *use-locatives* nil "See sloop.lisp") ;#+lispm t #-lispm nil
|
||||
;;If t should have locf, such that (setf b nil) (setq a (locf b)) then if
|
||||
;;(setf (cdr a) (cons 3 nil)) b==>(3). This is useful for building lists
|
||||
;;starting with a variable pointing to nil, since otherwise we must check
|
||||
;;each time if the list has really been started, before we do a
|
||||
;;(setf (cdr b) ..)
|
||||
|
||||
(defparameter *Automatic-declarations*
|
||||
#+lispm nil
|
||||
#-lispm
|
||||
'(:from fixnum
|
||||
:in #+kcl object #-kcl t
|
||||
:collect #+kcl object #-kcl t :count fixnum :max fixnum) "See sloop.lisp")
|
||||
;;Automatic declarations for variables in the stepping and collecting,
|
||||
;;so for i below n, gives i and n a :from declaration (here fixnum)
|
||||
;;for item in lis, gives (declare (t item))
|
||||
|
||||
(defparameter *macroexpand-hook-for-no-copy* #-(or lmi ti) 'funcall #+(or lmi ti) t)
|
||||
;;some lisps remember a macro so that (loop-return) will expand eq forms
|
||||
;;always in the same manner, even if the form is in a macrolet! To defeat this feature
|
||||
;;we copy all macro expansions unless *macro-expand-hook* = *macroexpand-hook-for-no-copy*
|
||||
)
|
||||
|
||||
;;*****ONLY CONDITIONALIZATIONS BELOW HERE SHOULD BE FOR BUG FIXES******
|
||||
;;eg. some kcls don't return nil from a prog by default!
|
||||
|
||||
;;all macros here in here.
|
||||
(eval-when (compile eval load)
|
||||
|
||||
(defparameter *sloop-translations* '((appending . append)
|
||||
((collecting collect) . collect)
|
||||
((maximizing maximize) . maximize)
|
||||
((minimizing minimize) . minimize)
|
||||
(nconcing . nconc)
|
||||
((count counting) . count)
|
||||
(as . for)
|
||||
(in-fringe . in-fringe)
|
||||
(collate . collate)
|
||||
(in-table . in-table)
|
||||
(in-carefully . in-carefully)
|
||||
(averaging . averaging)
|
||||
(in-array . in-array))
|
||||
"A list of cons's where the translation is the cdr, and the car
|
||||
is a list of names or name to be translated. Essentially allows 'globalizing'
|
||||
a symbol for the purposes of being a keyword in a sloop")
|
||||
|
||||
|
||||
(defparameter *additional-collections* nil)
|
||||
|
||||
(defmacro lcase (item &body body)
|
||||
(let (bod last-case tem)
|
||||
(do ((rest body (cdr rest)) (v))
|
||||
((or last-case (null rest)))
|
||||
(setq v (car rest))
|
||||
(push
|
||||
(cond ((eql (car v) t) (setq last-case t) v)
|
||||
((eql (car v) :collect)
|
||||
`((loop-collect-keyword-p .item.) ,@ (cdr v)))
|
||||
((eql (car v) :no-body)
|
||||
`((parse-no-body .item.) ,@ (cdr v)))
|
||||
((setq tem
|
||||
(member (car v) '(:sloop-macro :sloop-for :sloop-map)))
|
||||
`((get .item. ,(car tem)) ,@ (cdr v)))
|
||||
(t
|
||||
`((l-equal .item. ',(car v)) ,@ (cdr v))))
|
||||
bod))
|
||||
(or last-case (push `(t (error "lcase fell off end ~a " .item.)) bod))
|
||||
`(let ((.item. ,item))
|
||||
(cond ,@ (nreverse bod)))))
|
||||
|
||||
(define-setf-method cons (a b)
|
||||
(let ((store (gensym "store")))
|
||||
(values nil nil (list store)
|
||||
`(progn ,@ (and a `((setf ,a (car ,store))))
|
||||
,@ (and b `((setf ,b (cdr ,store)))))
|
||||
`(error "You should not be setting this"))))
|
||||
|
||||
(defmacro cons-for-setf (form)
|
||||
(cond ((symbolp form) form)
|
||||
((consp form)
|
||||
(cond ((cdr form)
|
||||
`(cons (cons-for-setf ,(car form)) (cons-for-setf ,(cdr form))))
|
||||
(t `(cons (cons-for-setf ,(car form)) nil))))))
|
||||
|
||||
(defmacro desetq (form val)
|
||||
"(desetq (a b) '(3 4)) would work. This is destructured setq"
|
||||
`(setf (cons-for-setf ,form) ,val))
|
||||
|
||||
(defmacro loop-return (&rest vals)
|
||||
(cond ((<= (length vals) 1)
|
||||
`(return ,@ vals))
|
||||
(t`(return (values ,@ vals)))))
|
||||
|
||||
(defmacro loop-finish ()
|
||||
`(go finish-loop))
|
||||
|
||||
(defmacro local-finish ()
|
||||
`(go finish-loop))
|
||||
|
||||
(defmacro sloop (&body body)
|
||||
(parse-loop body))
|
||||
|
||||
(defmacro def-loop-map (name args &body body)
|
||||
(def-loop-internal name args body 'map))
|
||||
(defmacro def-loop-for (name args &body body )
|
||||
(def-loop-internal name args body 'for nil 1))
|
||||
(defmacro def-loop-macro (name args &body body)
|
||||
(def-loop-internal name args body 'macro))
|
||||
(defmacro def-loop-collect (name arglist &body body )
|
||||
"Define function of 2 args arglist= (collect-var value-to-collect)"
|
||||
(def-loop-internal name arglist body 'collect '*additional-collections* 2 2))
|
||||
|
||||
(defmacro sloop-swap ()
|
||||
`(progn (rotatef a *loop-bindings*)
|
||||
(rotatef b *loop-prologue*)
|
||||
(rotatef c *loop-epilogue*)
|
||||
(rotatef e *loop-end-test*)
|
||||
(rotatef f *loop-increment*)
|
||||
(setf *inner-sloop* (not *inner-sloop*))
|
||||
))
|
||||
|
||||
)
|
||||
|
||||
(defun l-equal (a b)
|
||||
(and (symbolp a)
|
||||
(cond ((symbolp b)
|
||||
(equal (symbol-name a) (symbol-name b)))
|
||||
((listp b)
|
||||
(member a b :test 'l-equal)))))
|
||||
|
||||
(defun loop-collect-keyword-p (command)
|
||||
(or (member command '(collect append nconc sum count) :test 'l-equal)
|
||||
(find command *additional-collections* :test 'l-equal)))
|
||||
|
||||
(defun translate-name (name)
|
||||
(cond ((and (symbolp name)
|
||||
(cdar (member name *sloop-translations* :test 'l-equal :key 'car))))
|
||||
(t name)))
|
||||
|
||||
(defun loop-pop () (declare (special *last-val* *loop-form*))
|
||||
(cond (*loop-form*
|
||||
(setq *last-val* (translate-name (pop *loop-form*))))
|
||||
(t (setq *last-val* 'empty-form) nil)))
|
||||
|
||||
(defun loop-un-pop () (declare (special *last-val* *loop-form*))
|
||||
(case *last-val*
|
||||
(empty-form nil)
|
||||
(already-un-popped (error "you are un-popping without popping"))
|
||||
(t (push *last-val* *loop-form*) (setf *last-val* 'alread-un-popped))))
|
||||
|
||||
(defun loop-peek () (declare (special *last-val* *loop-form*))
|
||||
(translate-name (car *loop-form*)))
|
||||
|
||||
(defun parse-loop (form &aux inner-body)
|
||||
(let ((*loop-form* form)
|
||||
(*Automatic-declarations* *Automatic-declarations*)
|
||||
*last-val* *loop-map*
|
||||
*loop-body*
|
||||
*loop-name*
|
||||
*loop-prologue* *inner-sloop*
|
||||
*loop-epilogue* *loop-increment*
|
||||
*loop-collect-pointers* *loop-map-declares*
|
||||
*loop-collect-var* *no-declare*
|
||||
*loop-end-test*
|
||||
*loop-bindings*
|
||||
*product-for* local-macros
|
||||
(finish-loop 'finish-loop)
|
||||
)
|
||||
(declare (special *loop-form* *last-val* *loop-map*
|
||||
*loop-collect-pointers*
|
||||
*loop-name* *inner-sloop*
|
||||
*loop-body*
|
||||
*loop-prologue*
|
||||
*no-declare*
|
||||
*loop-bindings*
|
||||
*loop-collect-var* *loop-map-declares*
|
||||
*loop-epilogue* *loop-increment*
|
||||
*loop-end-test* *product-for*
|
||||
))
|
||||
(parse-loop1)
|
||||
(when (or *loop-map* *product-for*)
|
||||
(or *loop-name* (setf *loop-name* (gensym "SLOOP")))
|
||||
(and (eql 'finish-loop finish-loop)
|
||||
(setf finish-loop (gensym "FINISH"))))
|
||||
(and *loop-name*
|
||||
(push
|
||||
`(loop-return (&rest vals) `(return-from ,',*loop-name* (values ,@ vals)))
|
||||
local-macros))
|
||||
(unless (eql finish-loop 'finish-loop)
|
||||
(push `(loop-finish () `(go ,',finish-loop)) local-macros)
|
||||
(push `(local-finish () `(go ,',finish-loop)) local-macros))
|
||||
(and *loop-collect-var*
|
||||
(push `(return-from ,*loop-name* , *loop-collect-var*)
|
||||
*loop-epilogue*))
|
||||
(setq inner-body (append *loop-end-test*
|
||||
(nreverse *loop-body*)
|
||||
(nreverse *loop-increment*)))
|
||||
(cond (*loop-map*
|
||||
(setq inner-body (substitute-sloop-body inner-body)))
|
||||
(t (setf inner-body (cons 'next-loop
|
||||
(append inner-body '((go next-loop)))))))
|
||||
(let ((bod
|
||||
`(macrolet ,local-macros
|
||||
(block ,*loop-name*
|
||||
(tagbody
|
||||
,@ (append
|
||||
(nreverse *loop-prologue*)
|
||||
inner-body
|
||||
`(,finish-loop)
|
||||
(nreverse *loop-epilogue*)
|
||||
#+kcl '((loop-return nil))))))
|
||||
|
||||
))
|
||||
;;temp-fix..should not be necessary but some lisps cache macro expansions.
|
||||
;;and ignore the macrolet!!
|
||||
(unless (eql *macroexpand-hook* *macroexpand-hook-for-no-copy*)
|
||||
(setf bod (copy-tree bod)))
|
||||
(dolist (v *loop-bindings*)
|
||||
(setf bod
|
||||
`(let ,(car v) ,@(and (cdr v) `(,(cons 'declare (cdr v))))
|
||||
,bod)))
|
||||
bod
|
||||
)))
|
||||
|
||||
(defun parse-loop1 ()
|
||||
(declare (special *loop-form*
|
||||
*loop-body* *loop-increment*
|
||||
*no-declare* *loop-end-test*
|
||||
*loop-name* ))
|
||||
(lcase (loop-peek)
|
||||
(named (loop-pop) (setq *loop-name* (loop-pop)))
|
||||
(t nil))
|
||||
(do ((v (loop-pop) (loop-pop)))
|
||||
((and (null v) (null *loop-form*)))
|
||||
(lcase v
|
||||
(:no-body)
|
||||
(for (parse-loop-for))
|
||||
(while (push
|
||||
`(or ,(loop-pop) (loop-finish)) *loop-body*))
|
||||
(until (push
|
||||
`(and ,(loop-pop) (loop-finish)) *loop-body*))
|
||||
(do (setq *loop-body* (append (parse-loop-do) *loop-body*)))
|
||||
((when unless) (setq *loop-body* (append (parse-loop-when) *loop-body*)))
|
||||
(:collect (setq *loop-body* (append (parse-loop-collect) *loop-body*)))
|
||||
)))
|
||||
|
||||
|
||||
(defun parse-no-body (com &aux (found t) (first t))
|
||||
"Reads successive no-body-contribution type forms, like declare, initially, etc.
|
||||
which can occur anywhere. Returns t if it finds some
|
||||
otherwise nil"
|
||||
(declare (special *loop-form*
|
||||
*loop-body*
|
||||
*loop-increment*
|
||||
*no-declare* *loop-end-test*
|
||||
*loop-name* ))
|
||||
(do ((v com (loop-pop)))
|
||||
((null *loop-form*))
|
||||
(lcase v
|
||||
((initially finally)(parse-loop-initially v))
|
||||
(nil nil)
|
||||
(with (parse-loop-with))
|
||||
(declare (parse-loop-declare (loop-pop) t))
|
||||
(nodeclare (setq *no-declare* (loop-pop))) ;take argument to be consistent.
|
||||
(increment (setq *loop-increment* (append (parse-loop-do) *loop-increment*)))
|
||||
(end-test (setq *loop-end-test* (append (parse-loop-do) *loop-end-test*)))
|
||||
(with-unique (parse-loop-with nil t))
|
||||
(:sloop-macro (parse-loop-macro v :sloop-macro))
|
||||
(t (cond (first (setf found nil))
|
||||
(t (loop-un-pop)))
|
||||
(return 'done)))
|
||||
(setf first nil))
|
||||
found)
|
||||
|
||||
(defun parse-loop-with (&optional and-with only-if-not-there)
|
||||
(let ((var (loop-pop)))
|
||||
(lcase (loop-peek)
|
||||
(= (loop-pop)
|
||||
(or (symbolp var) (error "Not a variable ~a" var))
|
||||
(loop-add-binding var (loop-pop) (not and-with) nil nil t only-if-not-there) )
|
||||
(t (loop-add-temps var nil nil (not and-with) only-if-not-there)))
|
||||
(lcase (loop-peek)
|
||||
(and (loop-pop)
|
||||
(lcase (loop-pop)
|
||||
(with (parse-loop-with t ))
|
||||
(with-unique (parse-loop-with t t))
|
||||
))
|
||||
(t nil))))
|
||||
|
||||
(defun parse-loop-do (&aux result)
|
||||
(declare (special *loop-form*))
|
||||
(do ((v (loop-pop) (loop-pop)) )
|
||||
(())
|
||||
(cond
|
||||
((listp v)
|
||||
(push v result)
|
||||
(or *loop-form* (return 'done)))
|
||||
(t (loop-un-pop) (return 'done))))
|
||||
(or result (error "empty clause"))
|
||||
result)
|
||||
|
||||
(defun parse-loop-initially (command )
|
||||
(declare (special *loop-prologue* *loop-epilogue* *loop-bindings*))
|
||||
(lcase command
|
||||
(initially (let ((form (parse-loop-do)))
|
||||
(dolist (v (nreverse form))
|
||||
(cond ((and (listp v)
|
||||
(member (car v) '(setf setq))
|
||||
(eql (length v) 3)
|
||||
(symbolp (second v))
|
||||
(constantp (third v))
|
||||
(loop-add-binding (second v) (third v) nil nil nil t t)
|
||||
))
|
||||
(t (setf *loop-prologue* (cons v *loop-prologue*)))))))
|
||||
(finally
|
||||
(setf *loop-epilogue* (append (parse-loop-do) *loop-epilogue*)))))
|
||||
|
||||
(defun parse-one-when-clause ( &aux this-case (want 'body) v)
|
||||
(declare (special *loop-form*))
|
||||
(prog nil
|
||||
next-loop
|
||||
(and (null *loop-form*) (return 'done))
|
||||
(setq v (loop-pop))
|
||||
(lcase v
|
||||
(:no-body)
|
||||
(:collect (or (eql 'body want) (go finish))
|
||||
(setq this-case (append (parse-loop-collect) this-case))
|
||||
(setq want 'and))
|
||||
(when (or (eql 'body want) (go finish))
|
||||
(setq this-case (append (parse-loop-when) this-case))
|
||||
(setq want 'and))
|
||||
(do (or (eql 'body want) (go finish))
|
||||
(setq this-case (append (parse-loop-do) this-case))
|
||||
(setq want 'and))
|
||||
(and (or (eql 'and want) (error "Premature AND"))
|
||||
(setq want 'body))
|
||||
(t (loop-un-pop)(return 'done)))
|
||||
(go next-loop)
|
||||
finish
|
||||
(loop-un-pop))
|
||||
(or this-case (error "Hanging conditional"))
|
||||
this-case)
|
||||
|
||||
|
||||
(defun parse-loop-when (&aux initial else else-clause )
|
||||
(declare (special *last-val* ))
|
||||
(let ((test (cond ((l-equal *last-val* 'unless) `(not , (loop-pop)))
|
||||
(t (loop-pop)))))
|
||||
(setq initial (parse-one-when-clause))
|
||||
(lcase (loop-peek)
|
||||
(else
|
||||
(loop-pop)
|
||||
(setq else t)
|
||||
(setq else-clause (parse-one-when-clause)))
|
||||
(t nil))
|
||||
`((cond (,test ,@ (nreverse initial))
|
||||
,@ (and else `((t ,@ (nreverse else-clause))))))))
|
||||
|
||||
(defun pointer-for-collect (collect-var)
|
||||
(declare (special *loop-collect-pointers*))
|
||||
(or (cdr (assoc collect-var *loop-collect-pointers*))
|
||||
(let ((sym(loop-add-binding (gensym "POIN") nil nil :collect )))
|
||||
(push (cons collect-var sym)
|
||||
*loop-collect-pointers*)
|
||||
sym)))
|
||||
|
||||
(defun parse-loop-collect ( &aux collect-var pointer name-val)
|
||||
(declare (special *last-val* *loop-body* *loop-collect-var*
|
||||
*loop-collect-pointers* *inner-sloop*
|
||||
*loop-prologue* ))
|
||||
(and *inner-sloop* (throw 'collect nil))
|
||||
(let ((command *last-val*)
|
||||
(val (loop-pop)))
|
||||
(lcase (loop-pop)
|
||||
(into (loop-add-binding (setq collect-var (loop-pop)) nil nil t nil t ))
|
||||
(t (loop-un-pop)
|
||||
(cond (*loop-collect-var* (setf collect-var *loop-collect-var*))
|
||||
(t (setf collect-var
|
||||
(setf *loop-collect-var*
|
||||
(loop-add-binding (gensym "COLL") nil )))))))
|
||||
(lcase command
|
||||
((append nconc collect)
|
||||
(setf pointer (pointer-for-collect collect-var))
|
||||
(cond (*use-locatives*
|
||||
(pushnew `(setf ,pointer
|
||||
(locf ,collect-var)) *loop-prologue* :test 'equal)))
|
||||
(lcase command
|
||||
( append
|
||||
(unless (and (listp val) (eql (car val) 'list))
|
||||
(setf val `(copy-list ,val))))
|
||||
(t nil)))
|
||||
(t nil))
|
||||
(cond ((and (listp val) (not *use-locatives*))
|
||||
(setq name-val (loop-add-binding (gensym "VAL") nil nil)))
|
||||
(t (setf name-val val)))
|
||||
(let
|
||||
((result
|
||||
(lcase command
|
||||
((nconc append)
|
||||
(let ((set-pointer `(and (setf (cdr ,pointer) ,name-val)
|
||||
(setf ,pointer (last (cdr ,pointer))))))
|
||||
(cond (*use-locatives*
|
||||
(list set-pointer))
|
||||
(t
|
||||
`((cond (,pointer ,set-pointer)
|
||||
(t (setf ,pointer (last (setf ,collect-var ,name-val))))))))))
|
||||
(collect
|
||||
(cond (*use-locatives*
|
||||
`((setf (cdr ,pointer) (setf ,pointer (cons ,name-val nil)))))
|
||||
(t `((cond (,pointer (setf (cdr ,pointer)
|
||||
(setf ,pointer (cons ,name-val nil))))
|
||||
(t (setf ,collect-var
|
||||
(setf ,pointer (cons ,name-val nil)))))))))
|
||||
(t (cond ((find command *additional-collections* :test 'l-equal)
|
||||
(loop-parse-additional-collections command collect-var name-val))
|
||||
(t (error "loop fell off end ~a" command)))))))
|
||||
(cond ((eql name-val val)
|
||||
result)
|
||||
(t (nconc result `((setf ,name-val ,val) )))))))
|
||||
|
||||
(defun loop-parse-additional-collections (command collect-var name-val &aux eachtime)
|
||||
(declare (special *loop-prologue* *last-val* *loop-collect-var* *loop-epilogue* ))
|
||||
(let* ((com (find command *additional-collections* :test 'l-equal))
|
||||
(helper (get com :sloop-collect)))
|
||||
(let ((form (funcall helper collect-var name-val)))
|
||||
(let ((*loop-form* form) *last-val*)
|
||||
(declare (special *loop-form* *last-val*))
|
||||
(do ((v (loop-pop) (loop-pop)))
|
||||
((null *loop-form*))
|
||||
(lcase v
|
||||
(:no-body)
|
||||
(do (setq eachtime (parse-loop-do)))))
|
||||
eachtime))))
|
||||
|
||||
(defun the-type (symbol type)
|
||||
(declare (special *no-declare*))
|
||||
(and *no-declare* (setf type nil))
|
||||
(and type (setf type (or (getf *Automatic-declarations* type)
|
||||
(and (not (keywordp type)) type))))
|
||||
(cond (type (list 'the type symbol ))
|
||||
(t symbol)))
|
||||
|
||||
;;keep track of the bindings in a list *loop-bindings*
|
||||
;;each element of the list will give rise to a different let.
|
||||
;;the car will be the variable bindings,
|
||||
;;the cdr the declarations.
|
||||
(defun loop-add-binding
|
||||
(variable value &optional (new-level t) type force-type (force-new-value t)
|
||||
only-if-not-there &aux tem)
|
||||
"Add a variable binding to the current or new level.
|
||||
If FORCE-TYPE, ignore a *no-declare*.
|
||||
If ONLY-IF-NOT-THERE, check all levels."
|
||||
(declare (special *loop-bindings*))
|
||||
(when (or new-level (null *loop-bindings*)) (push (cons nil nil) *loop-bindings*))
|
||||
(cond ((setq tem (assoc variable (caar *loop-bindings*) ))
|
||||
(and force-new-value
|
||||
(setf (cdr tem) (and value (list value)))))
|
||||
((and (or only-if-not-there (and (null (symbol-package variable))
|
||||
(constantp value)))
|
||||
(dolist (v (cdr *loop-bindings*))
|
||||
(cond ((setq tem (assoc variable (car v)))
|
||||
(and force-new-value
|
||||
(setf (cdr tem) (and value (list value))))
|
||||
(return t))))))
|
||||
(t (push (cons variable (and value (list value)))
|
||||
(caar *loop-bindings*))))
|
||||
(and type (loop-declare-binding variable type force-type))
|
||||
variable)
|
||||
|
||||
;(defmacro nth-level (n) `(nth ,n *loop-bindings*))
|
||||
;if x = (nth i *loop-bindings*)
|
||||
;(defmacro binding-declares (x) `(cdr ,x)) ;(cons 'declare (binding-declares x)) to get honest declare statement
|
||||
;(defmacro binding-values (x) `(car ,x)) ;(let (binding-values x) ) to get let.
|
||||
|
||||
(defun loop-declare-binding (var type force-type &aux found tem)
|
||||
(declare (special *loop-bindings* *Automatic-declarations* *no-declare* *loop-map*))
|
||||
(and type (setf type (or (getf *Automatic-declarations* type)
|
||||
(and (not (keywordp type)) type))))
|
||||
(when (and type(or force-type (null *no-declare*)))
|
||||
(dolist (v *loop-bindings*)
|
||||
(cond ((assoc var (car v))
|
||||
(setq found t)
|
||||
(or (setq tem(member var (cdr v) :key 'cadr))
|
||||
(progn (push (list nil var) (cdr v)) (setq tem (cdr v))))
|
||||
(setf (caar tem) type))))
|
||||
(or found *loop-map* (error "Could not find variable ~a in bindings" var))
|
||||
var))
|
||||
|
||||
(defun parse-loop-declare (&optional (decl-list (loop-pop)) (force t))
|
||||
(dolist (v (cdr decl-list))
|
||||
(loop-declare-binding v (car decl-list) force)))
|
||||
|
||||
(defun loop-add-temps (form &optional val type new-level only-if-not-there)
|
||||
(cond ((null form))
|
||||
((symbolp form)
|
||||
(loop-add-binding form val new-level type nil t only-if-not-there))
|
||||
((listp form)
|
||||
(loop-add-temps (car form))
|
||||
(loop-add-temps (cdr form)))))
|
||||
|
||||
(defun parse-loop-for ( &aux direction)
|
||||
(declare (special *loop-form* *loop-map-declares* *loop-map*
|
||||
*loop-body* *loop-increment*
|
||||
*loop-prologue*
|
||||
*loop-epilogue*
|
||||
*loop-end-test*
|
||||
*loop-bindings*
|
||||
))
|
||||
(let* ((var (loop-pop)) test incr
|
||||
(varl var))
|
||||
(do ((v (loop-pop) (loop-pop)))
|
||||
(())
|
||||
(lcase v
|
||||
(in (let ((lis (gensym "LIS")))
|
||||
(loop-add-temps var nil :in t)
|
||||
(loop-add-binding lis (loop-pop) nil)
|
||||
(push `(desetq ,var (car ,lis)) *loop-body*)
|
||||
(setf incr `(setf ,lis (cdr ,lis)))
|
||||
(setq test `(null ,lis) )
|
||||
))
|
||||
(on (let ((lis
|
||||
(cond ((symbolp var) var)
|
||||
(t (gensym "LIS")))))
|
||||
(loop-add-temps var nil :in t)
|
||||
(loop-add-binding lis (loop-pop) nil)
|
||||
(setf incr `(setf ,lis (cdr ,lis)))
|
||||
(unless (eql lis var)
|
||||
(push `(desetq ,var ,lis) *loop-body*))
|
||||
(setf test `(null ,lis))))
|
||||
((upfrom from)
|
||||
(loop-add-binding var (loop-pop) (not(prog1 direction (setf direction 'up))) :from)
|
||||
(setf incr `(setf ,var ,(the-type `(+ ,var 1) :from))))
|
||||
(downfrom
|
||||
(loop-add-binding var (loop-pop) (not(prog1 direction (setf direction 'down))) :from)
|
||||
(setf incr `(setf ,var ,(the-type `(- ,var 1) :from))))
|
||||
(by (let ((inc (loop-pop)))
|
||||
(cond ((and (listp inc)(eql (car inc) 'quote))
|
||||
(setf inc (second inc))
|
||||
))
|
||||
(cond (direction
|
||||
(setf incr (subst inc 1 incr)))
|
||||
(t (setf incr (subst inc 'cdr incr))))))
|
||||
(below
|
||||
(let ((lim (gensym "LIM")))
|
||||
(loop-add-binding var 0 (not(prog1 direction (setf direction 'up)))
|
||||
:from nil nil)
|
||||
(loop-add-binding lim (loop-pop) nil :from )
|
||||
(or incr (setf incr `(setf ,var ,(the-type `(+ ,var 1) :from))))
|
||||
(setq test `(>= ,var ,lim))))
|
||||
(above
|
||||
(let ((lim (gensym "ABOVE")))
|
||||
(loop-add-binding var 0 (not(prog1 direction (setf direction 'down)))
|
||||
:from nil nil)
|
||||
(loop-add-binding lim (loop-pop) nil :from )
|
||||
(or incr (setf incr `(setf ,var ,(the-type `(- ,var 1) :from))))
|
||||
(setq test `(<= ,var ,lim))))
|
||||
(to
|
||||
(let ((lim (gensym "LIM")))
|
||||
(loop-add-binding var 0 (not(prog1 direction (or direction (setf direction 'up))))
|
||||
:from nil nil)
|
||||
(loop-add-binding lim (loop-pop) nil :from )
|
||||
(or incr (setf incr `(setf ,var ,(the-type `(+ ,var 1) :from))))
|
||||
(setq test `(,(if (eql direction 'down) '< '>),var ,lim))))
|
||||
(:sloop-for (parse-loop-macro v :sloop-for var ) (setf varl nil)(return 'done))
|
||||
(:sloop-map (parse-loop-map v var ) (return nil))
|
||||
(t(or ; (null *loop-form*)
|
||||
(loop-un-pop))
|
||||
(return 'done))))
|
||||
;;temporary fix for bad macrolet on explorer and dec-20.
|
||||
(and test (push (copy-tree `(and ,test (local-finish))) *loop-end-test*))
|
||||
(and incr (push incr *loop-increment*))))
|
||||
|
||||
(defun parse-loop-macro (v type &optional initial &aux result)
|
||||
(declare (special *loop-form*))
|
||||
(let ((helper (get v type)) args)
|
||||
(setq args
|
||||
(ecase type
|
||||
(:sloop-for
|
||||
(let ((tem (get v :sloop-for-args)))
|
||||
(or (cdr tem) (error "sloop-for macro needs at least one arg"))
|
||||
(cdr tem)))
|
||||
(:sloop-macro(get v :sloop-macro-args))))
|
||||
(let ((last-helper-apply-arg
|
||||
(cond ((member '&rest args) (prog1 *loop-form* (setf *loop-form* nil)))
|
||||
(t (dotimes (i (length args) (nreverse result))
|
||||
(push (car *loop-form*) result)
|
||||
(setf *loop-form* (cdr *loop-form*)))))))
|
||||
(setq *loop-form*
|
||||
(append
|
||||
(case type
|
||||
(:sloop-for (apply helper initial last-helper-apply-arg))
|
||||
(:sloop-macro(apply helper last-helper-apply-arg)))
|
||||
*loop-form*)))))
|
||||
|
||||
(defun parse-loop-map (v var)
|
||||
(declare (special *loop-map* *loop-map-declares* *loop-form*))
|
||||
(and *loop-map* (error "Sorry only one allowed loop-map per sloop"))
|
||||
(let ((helper (get v :sloop-map))
|
||||
(args (get v :sloop-map-args)))
|
||||
(or args (error "map needs one arg before the key word"))
|
||||
(cond ((member '&rest args)(error "Build this in two steps if you want &rest")))
|
||||
(let* (result
|
||||
(last-helper-apply-arg
|
||||
(dotimes (i (1- (length args)) (nreverse result))
|
||||
(push (car *loop-form*) result) (setf *loop-form* (cdr *loop-form*)))))
|
||||
(setq *loop-map-declares*
|
||||
(do ((v (loop-pop)(loop-pop)) (result))
|
||||
((null (l-equal v 'declare))
|
||||
(loop-un-pop)
|
||||
(and result (cons 'declare result)))
|
||||
(push (loop-pop) result)))
|
||||
(setq *loop-map* (apply helper var last-helper-apply-arg))
|
||||
nil)))
|
||||
|
||||
(defun substitute-sloop-body (inner-body)
|
||||
(declare (special *loop-map* *loop-map-declares*))
|
||||
(cond (*loop-map*
|
||||
(setf inner-body (list (subst (cons 'progn inner-body)
|
||||
:sloop-body *loop-map*)))
|
||||
(and *loop-map-declares*
|
||||
(setf inner-body(subst *loop-map-declares*
|
||||
:sloop-map-declares inner-body)))))
|
||||
inner-body)
|
||||
|
||||
;;;**User Extensible Iteration Facility**
|
||||
|
||||
(eval-when (compile eval load)
|
||||
(defun def-loop-internal (name args body type &optional list min-args max-args
|
||||
&aux (*print-case* :upcase) (helper (intern (format nil "~a-SLOOP-~a" name type))))
|
||||
(and min-args (or (>= (length args) min-args)(error "need more args")))
|
||||
(and max-args (or (<= (length args) max-args)(error "need less args")))
|
||||
`(eval-when (load compile eval)
|
||||
(defun ,helper ,args
|
||||
,@ body)
|
||||
,@ (and list `((pushnew ',name ,list)))
|
||||
(setf (get ',name ,(intern (format nil "SLOOP-~a" type) (find-package 'keyword))) ',helper)
|
||||
(setf (get ',name ,(intern (format nil "SLOOP-~a-ARGS" type)(find-package 'keyword))) ',args)))
|
||||
)
|
||||
|
||||
|
||||
;;DEF-LOOP-COLLECT
|
||||
;;lets you get a handle on the collection var.
|
||||
;;exactly two args.
|
||||
;;First arg=collection-variable
|
||||
;;Second arg=value this time thru the loop.
|
||||
(def-loop-collect sum (ans val)
|
||||
`(initially (setq ,ans 0)
|
||||
do (setq ,ans (+ ,ans ,val))))
|
||||
(def-loop-collect logxor (ans val)
|
||||
`(initially (setf ,ans 0)
|
||||
do (setf ,ans (logxor ,ans ,val))
|
||||
declare (fixnum ,ans ,val)))
|
||||
(def-loop-collect maximize (ans val)
|
||||
`(initially (setq ,ans nil)
|
||||
do (if ,ans (setf ,ans (max ,ans ,val)) (setf ,ans ,val))
|
||||
declare (fixnum ,val)))
|
||||
(def-loop-collect minimize (ans val)
|
||||
`(initially (setq ,ans nil)
|
||||
do (if ,ans (setf ,ans (min ,ans ,val)) (setf ,ans ,val))
|
||||
declare (fixnum ,val)))
|
||||
(def-loop-collect count (ans val)
|
||||
`(initially (setq ,ans 0)
|
||||
do (and ,val (setf ,ans (1+ ,ans)))
|
||||
declare (fixnum ,ans )))
|
||||
(def-loop-collect thereis (ans val) ans `(do (if ,val (loop-return ,val))))
|
||||
(def-loop-collect always (ans val) `(initially (setq ,ans t) do (and (null ,val)(loop-return nil))))
|
||||
(def-loop-collect never (ans val) `(initially (setq ,ans t) do (and ,val (loop-return nil))))
|
||||
|
||||
|
||||
;;DEF-LOOP-MACRO
|
||||
;;If we have done
|
||||
;(def-loop-macro averaging (x)
|
||||
; `(sum ,x into .tot. and count t into .how-many.
|
||||
; finally (loop-return (/ .tot. (float .how-many.)))))
|
||||
|
||||
;(def-loop-collect average (ans val)
|
||||
; `(initially (setf ,ans 0.0)
|
||||
; with-unique .how-many. = 0
|
||||
; do (setf ,ans (/ (+ (* .how-many. ,ans) ,val) (incf .how-many.)))
|
||||
; ))
|
||||
|
||||
;;provides averaging with current value the acutal average.
|
||||
(def-loop-macro averaging (x)
|
||||
`(with-unique .average. = 0.0
|
||||
and with-unique .n-to-average. = 0
|
||||
declare (float .average. ) declare (fixnum .n-to-average.)
|
||||
do (setf .average. (/ (+ (* .n-to-average. .average.) ,x) (incf .n-to-average.)))
|
||||
finally (loop-return .average.)))
|
||||
|
||||
|
||||
;;then we can write:
|
||||
;(sloop for x in l when (oddp x) averaging x)
|
||||
|
||||
|
||||
;;DEF-LOOP-FOR
|
||||
;;def-loop-for and def-loop-macro
|
||||
;;are almost identical except that the def-loop-for construct can only occur
|
||||
;;after a for:
|
||||
;(def-loop-for in-array (vars array)
|
||||
; (let ((elt (car vars))
|
||||
; (ind (second vars)))
|
||||
; `(for ,ind below (length ,array) do (setf ,elt (aref ,array ,ind)))))
|
||||
;; (sloop for (elt ind) in-array ar when (oddp elt) collecting ind)
|
||||
;;You are just building something understandable by loop but minus the for.
|
||||
;;Since this is almost like a "macro", and users may want to customize their
|
||||
;;own, the comparsion of tokens uses eq, ie. you must import IN-ARRAY to your package
|
||||
;;if you define it in another one. Actually we make a fancier in-array
|
||||
;;below which understands from, to, below, downfrom,.. and can have
|
||||
;;either (elt ind) or elt as the argument vars.
|
||||
|
||||
;;DEF-LOOP-MAP
|
||||
;;A rather general iteration construct which allows you to map over things
|
||||
;;It can only occur after FOR.
|
||||
;;There can only be one loop-map for a given loop, so you want to only
|
||||
;;use them for complicated iterations.
|
||||
|
||||
(def-loop-map in-table (var table)
|
||||
`(maphash #'(lambda ,var :sloop-map-declares :sloop-body) ,table))
|
||||
;Usage (sloop for (key elt) in-table table
|
||||
; declare (fixnum elt)
|
||||
; when (oddp elt) collecting (cons key elt))
|
||||
|
||||
|
||||
(def-loop-map in-package (var package)
|
||||
`(do-symbols (,var (find-package ,package)) :sloop-body))
|
||||
|
||||
;(defun te()(sloop for sym in-package 'sloop when (fboundp sym) count t))
|
||||
|
||||
;;in-array that understands from,downfrowm,to, below, above,etc.
|
||||
;;I used a do for the macro iteration to be able include it here.
|
||||
(def-loop-for in-array (vars array &rest args)
|
||||
(let (elt ind from to)
|
||||
(cond ((listp vars) (setf elt (car vars) ind (second vars)))
|
||||
(t (setf elt vars ind (gensym "INDEX" ))))
|
||||
(let ((skip (do ((v args (cddr v)) (result))
|
||||
(())
|
||||
(lcase (car v)
|
||||
((from downfrom) (setf from t))
|
||||
((to below above) (setf to t))
|
||||
(by)
|
||||
(t (setq args (copy-list v)) (return (nreverse result))))
|
||||
(push (car v) result) (push (second v) result))))
|
||||
(or to (setf skip (nconc `(below (length ,array)) skip)))
|
||||
`(for ,ind
|
||||
,@ skip
|
||||
with ,elt
|
||||
do (setf ,elt (aref ,array ,ind)) ,@ args))))
|
||||
|
||||
;usage: IN-ARRAY
|
||||
;(sloop for (elt i) in-array ar from 4
|
||||
; when (oddp i)
|
||||
; collecting elt)
|
||||
|
||||
;(sloop for elt in-array ar below 10 by 2
|
||||
; do (print elt))
|
||||
|
||||
|
||||
(def-loop-macro sloop (for-loop)
|
||||
(lcase (car for-loop)
|
||||
(for))
|
||||
(let (*inner-sloop* *loop-body* *loop-map* inner-body
|
||||
(finish-loop (gensym "FINISH"))
|
||||
a b c e f (*loop-form* for-loop))
|
||||
(declare (special *inner-sloop* *loop-end-test* *loop-increment*
|
||||
*product-for* *loop-map*
|
||||
*loop-form* *loop-body* *loop-prologue* *loop-epilogue* *loop-end-test*
|
||||
*loop-bindings*
|
||||
))
|
||||
(setf *product-for* t)
|
||||
(loop-pop)
|
||||
(sloop-swap)
|
||||
(parse-loop-for)
|
||||
(sloop-swap)
|
||||
(do ()
|
||||
((null *loop-form*))
|
||||
(cond ((catch 'collect (parse-loop1)))
|
||||
((null *loop-form*)(return 'done))
|
||||
(t ;(fsignal "hi")
|
||||
(print *loop-form*)
|
||||
(sloop-swap)
|
||||
(parse-loop-collect)
|
||||
(sloop-swap)
|
||||
(print *loop-form*)
|
||||
)))
|
||||
(sloop-swap)
|
||||
(setf inner-body (nreverse *loop-body*))
|
||||
(and *loop-map* (setf inner-body (substitute-sloop-body inner-body)))
|
||||
(let ((bod
|
||||
`(macrolet ((local-finish () `(go ,',finish-loop)))
|
||||
(tagbody
|
||||
,@ (nreverse *loop-prologue*)
|
||||
,@ (and (null *loop-map*) '(next-loop))
|
||||
,@ (nreverse *loop-end-test*)
|
||||
,@ inner-body
|
||||
,@ (nreverse *loop-increment*)
|
||||
,@ (and (null *loop-map*) '((go next-loop)))
|
||||
,finish-loop
|
||||
,@ (nreverse *loop-epilogue*)))))
|
||||
(dolist (v *loop-bindings*)
|
||||
(setf bod
|
||||
`(let ,(car v) ,@(and (cdr v) `(,(cons 'declare (cdr v))))
|
||||
,bod)))
|
||||
(sloop-swap)
|
||||
`(do ,bod))))
|
||||
|
||||
;Usage: SLOOP (FOR
|
||||
;(defun te ()
|
||||
; (sloop for i below 5
|
||||
; sloop (for j to i collecting (list i j))))
|
||||
|
||||
(def-loop-for in-carefully (var lis)
|
||||
"Path with var in lis except lis may end with a non nil cdr"
|
||||
(let ((point (gensym "POINT")))
|
||||
`(with ,point and with ,var initially (setf ,point ,lis)
|
||||
do(desetq ,var (car ,point))
|
||||
end-test (and (atom ,point)(local-finish))
|
||||
increment (setf ,point (cdr ,point)))))
|
||||
|
||||
;usage: IN-CAREFULLY
|
||||
;(defun te (l)
|
||||
; (sloop for v in-carefully l collecting v))
|
||||
|
||||
(defvar *collate-order* #'<)
|
||||
|
||||
;;of course this should be a search of the list based on the
|
||||
;;order and splitting into halves. I have one such written,
|
||||
;;but for short lists it may not be important. It takes more space.
|
||||
(defun find-in-ordered-list
|
||||
(it list &optional (order-function *collate-order*) &aux prev)
|
||||
(do ((v list (cdr v)))
|
||||
((null v) (values prev nil))
|
||||
(cond ((eql (car v) it) (return (values v t)))
|
||||
((funcall order-function it (car v))
|
||||
(return (values prev nil))))
|
||||
(setq prev v)))
|
||||
|
||||
(def-loop-collect collate (ans val)
|
||||
"Collects values into a sorted list without duplicates.
|
||||
Order based order function *collate-order*"
|
||||
`(do (multiple-value-bind
|
||||
(after already-there )
|
||||
(find-in-ordered-list ,val ,ans)
|
||||
(unless already-there
|
||||
(cond (after (setf (cdr after) (cons ,val (cdr after))))
|
||||
(t (setf ,ans (cons ,val ,ans))))))))
|
||||
|
||||
;usage: COLLATE
|
||||
;(defun te ()
|
||||
; (let ((res
|
||||
; (sloop for i below 10
|
||||
; sloop (for j downfrom 8 to 0
|
||||
; collate (* i (mod j (max i 1)) (random 2)))))
|
||||
|
||||
(defun map-fringe (fun tree)
|
||||
(do ((v tree))
|
||||
(())
|
||||
(cond ((atom v)
|
||||
(and v (funcall fun v))(return 'done))
|
||||
((atom (car v))
|
||||
(funcall fun (car v)))
|
||||
(t (map-fringe fun (car v) )))
|
||||
(setf v (cdr v))))
|
||||
|
||||
(def-loop-map in-fringe (var tree)
|
||||
"Map over the non nil atoms in the fringe of tree"
|
||||
`(map-fringe #'(lambda (,var) :sloop-map-declares :sloop-body) ,tree))
|
||||
|
||||
;;usage: IN-FRINGE
|
||||
;(sloop for v in-fringe '(1 2 (3 (4 5) . 6) 8 1 2)
|
||||
; declare (fixnum v)
|
||||
; maximize v)
|
||||
43
internal/test/tools/TEST-ARITHMETIC-UTILS
Normal file
43
internal/test/tools/TEST-ARITHMETIC-UTILS
Normal file
@@ -0,0 +1,43 @@
|
||||
(FILECREATED "23-Jul-85 12:55:55" {DSK}<LISPFILES>TESTER>SOURCES>TEST-ARITHMETIC-UTILS.;3 1675
|
||||
|
||||
changes to: (VARS TEST-ARITHMETIC-UTILSCOMS TEST.BIGNUM-SPECIAL-NUMBERS)
|
||||
(FNS TEST.GENERAL-IPLUS-SUCCESS-PREDICATE)
|
||||
|
||||
previous date: "11-Jul-85 11:05:16" {DSK}<LISPFILES>TESTER>TEST-ARITHMETIC-UTILS.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TEST-ARITHMETIC-UTILSCOMS)
|
||||
|
||||
(RPAQQ TEST-ARITHMETIC-UTILSCOMS ((FNS TEST.GENERAL-IPLUS-SUCCESS-PREDICATE TEST.NON-NUMERIC-ERROR)
|
||||
(VARS TEST.BIGNUM-SPECIAL-NUMBERS)))
|
||||
(DEFINEQ
|
||||
|
||||
(TEST.GENERAL-IPLUS-SUCCESS-PREDICATE
|
||||
[LAMBDA (RESULT ARGUMENTS) (* sm "18-Jul-85 18:29")
|
||||
(if (TEST.ERRORP RESULT)
|
||||
then (QUOTE FAILURE)
|
||||
else (for ARGUMENT in ARGUMENTS do (SETQ RESULT (IDIFFERENCE RESULT ARGUMENT)))
|
||||
(if (ZEROP RESULT)
|
||||
then (QUOTE SUCCESS)
|
||||
else (QUOTE FAILURE])
|
||||
|
||||
(TEST.NON-NUMERIC-ERROR
|
||||
[LAMBDA (RES ARGS) (* sm " 3-Jul-85 10:49")
|
||||
(if (AND (TEST.ERRORP RES)
|
||||
(EQP (CADR RES)
|
||||
10))
|
||||
then (QUOTE SUCCESS)
|
||||
else (QUOTE FAILURE])
|
||||
)
|
||||
|
||||
(RPAQQ TEST.BIGNUM-SPECIAL-NUMBERS (0 1 -1 16382 -16382 16383 -16383 16384 -16384 32766 -32766 32767
|
||||
-32767 32768 -32768 65534 -65534 65536 -65536 16777214
|
||||
-16777214 16777215 -16777215 16777216 -16777216 134217726
|
||||
-134217726 134217727 -134217727 134217728 -134217728))
|
||||
(PUTPROPS TEST-ARITHMETIC-UTILS COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (585 1276 (TEST.GENERAL-IPLUS-SUCCESS-PREDICATE 595 . 1007) (TEST.NON-NUMERIC-ERROR 1009
|
||||
. 1274)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/TEST-ARITHMETIC-UTILS.LCOM
Normal file
BIN
internal/test/tools/TEST-ARITHMETIC-UTILS.LCOM
Normal file
Binary file not shown.
37
internal/test/tools/TEST-DISPLAY-UTILS
Normal file
37
internal/test/tools/TEST-DISPLAY-UTILS
Normal file
@@ -0,0 +1,37 @@
|
||||
(FILECREATED "11-Jul-85 11:05:36" {DSK}<LISPFILES>TESTER>TEST-DISPLAY-UTILS.;1 1341
|
||||
|
||||
changes to: (VARS TEST-DISPLAY-UTILSCOMS))
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TEST-DISPLAY-UTILSCOMS)
|
||||
|
||||
(RPAQQ TEST-DISPLAY-UTILSCOMS ((FNS TEST.COMPARE-BITMAPS)))
|
||||
(DEFINEQ
|
||||
|
||||
(TEST.COMPARE-BITMAPS
|
||||
[LAMBDA (B1 B2) (* sm " 3-Jul-85 14:47")
|
||||
(AND (BITMAPP B1)
|
||||
(BITMAPP B2)
|
||||
(LET ((BASE1 (fetch BITMAPBASE of B1))
|
||||
(BASE2 (fetch BITMAPBASE of B2))
|
||||
(HEIGHT1 (fetch BITMAPHEIGHT of B1))
|
||||
(HEIGHT2 (fetch BITMAPHEIGHT of B2))
|
||||
(RW1 (fetch BITMAPRASTERWIDTH of B1))
|
||||
(RW2 (fetch BITMAPRASTERWIDTH of B2)))
|
||||
(COND
|
||||
((AND (EQ RW1 RW2)
|
||||
(EQ HEIGHT1 HEIGHT2))
|
||||
(for I from 1 to HEIGHT1 as J from 1 to HEIGHT2
|
||||
always (PROG1 (for WORDCOLUMN from 0 to (SUB1 RW1) always (EQ (\GETBASE BASE1
|
||||
WORDCOLUMN)
|
||||
(\GETBASE BASE2
|
||||
WORDCOLUMN)))
|
||||
(SETQ BASE1 (\ADDBASE BASE1 RW1))
|
||||
(SETQ BASE2 (\ADDBASE BASE2 RW2])
|
||||
)
|
||||
(PUTPROPS TEST-DISPLAY-UTILS COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (318 1252 (TEST.COMPARE-BITMAPS 328 . 1250)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/TEST-DISPLAY-UTILS.LCOM
Normal file
BIN
internal/test/tools/TEST-DISPLAY-UTILS.LCOM
Normal file
Binary file not shown.
46
internal/test/tools/TEST-FILING-UTILS
Normal file
46
internal/test/tools/TEST-FILING-UTILS
Normal file
@@ -0,0 +1,46 @@
|
||||
(FILECREATED "11-Jul-85 11:06:01" {DSK}<LISPFILES>TESTER>TEST-FILING-UTILS.;1 1625
|
||||
|
||||
changes to: (VARS TEST-FILING-UTILSCOMS))
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TEST-FILING-UTILSCOMS)
|
||||
|
||||
(RPAQQ TEST-FILING-UTILSCOMS ((FNS TEST.NSFILING.READ-AND-COMPARE TEST.NSFILING.WRITE-RANDOM-FILE)))
|
||||
(DEFINEQ
|
||||
|
||||
(TEST.NSFILING.READ-AND-COMPARE
|
||||
[LAMBDA (RES ARGS) (* sm "21-Jun-85 09:30")
|
||||
(PROG (FILENAME DATA NEXT-ITEM NEXT-ITEM ERROR-FOUND)
|
||||
(SETQ FILENAME RES)
|
||||
(SETQ DATA (CADR ARGS))
|
||||
(OPENFILE FILENAME (QUOTE INPUT)
|
||||
(QUOTE OLD))
|
||||
(while (AND (NOT ERROR-FOUND)
|
||||
(EOFP FILENAME))
|
||||
do (SETQ NEXT-ITEM (READ FILENAME))
|
||||
(SETQ ERROR-FOUND (NOT (EQUAL (CAR DATA)
|
||||
NEXT-ITEM)))
|
||||
(SETQ DATA (CDR DATA)))
|
||||
(CLOSEF FILENAME)
|
||||
(if ERROR-FOUND
|
||||
then (RETURN (QUOTE FAILURE))
|
||||
else (RETURN (QUOTE SUCCESS])
|
||||
|
||||
(TEST.NSFILING.WRITE-RANDOM-FILE
|
||||
[LAMBDA (FILENAME DATA) (* sm "21-Jun-85 09:26")
|
||||
(PROG (FULLNAME)
|
||||
(SETQ FULLNAME (OPENFILE FILENAME (QUOTE OUTPUT)
|
||||
(QUOTE NEW)))
|
||||
(for ITEM in DATA
|
||||
do (PRIN2 ITEM FULLNAME)
|
||||
(PRIN1 " " FULLNAME))
|
||||
(ENDFILE FULLNAME)
|
||||
(RETURN FULLNAME])
|
||||
)
|
||||
(PUTPROPS TEST-FILING-UTILS COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (356 1537 (TEST.NSFILING.READ-AND-COMPARE 366 . 1113) (TEST.NSFILING.WRITE-RANDOM-FILE
|
||||
1115 . 1535)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/TEST-FILING-UTILS.LCOM
Normal file
BIN
internal/test/tools/TEST-FILING-UTILS.LCOM
Normal file
Binary file not shown.
293
internal/test/tools/TEST-REMOTE-EVAL
Normal file
293
internal/test/tools/TEST-REMOTE-EVAL
Normal file
@@ -0,0 +1,293 @@
|
||||
(FILECREATED "11-Jul-85 11:39:07" {DSK}<LISPFILES>TESTER>TEST-REMOTE-EVAL.;4 13178
|
||||
|
||||
changes to: (VARS TEST-REMOTE-EVALCOMS)
|
||||
|
||||
previous date: "11-Jul-85 10:20:19" {DSK}<LISPFILES>TESTER>TEST-REMOTE-EVAL.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TEST-REMOTE-EVALCOMS)
|
||||
|
||||
(RPAQQ TEST-REMOTE-EVALCOMS ((FNS TEST.CALL-SOMEONE-FOR-HELP TEST.ESTIMATE-FILE-PRINTING-TIME
|
||||
TEST.ESTIMATE-FILE-READING-TIME TEST.EVAL-FORM-AT-HOST
|
||||
TEST.FLAG-CONTROLED-REMOTE-EVAL TEST.LOAD-FORM-AND-EVAL
|
||||
TEST.NONE-BREAK-REMOTEVAL TEST.OPEN-INPUT-FILE-OR-WAIT
|
||||
TEST.PRINT-RESULT-ON-FILE TEST.READ-FORM-FILE TEST.REMOTE-EVAL-FORM
|
||||
TEST.REMOTE-EVAL-USING-FILE TEST.WAIT-ON-FLAG)
|
||||
(VARS TEST.COMMUNICATION-FLAG TEST.GLOBAL-FORM-IN-HOST-MACHINE
|
||||
TEST.GLOBAL-RESULT-IN-HOST-MACHINE)
|
||||
(GLOBALVARS (TEST.EVAL-SERVER-HOST (QUOTE 222#24#))
|
||||
(TEST.FORM-FILE-NAME (QUOTE {ERIS}<MARKOVITCH>TESTER>TESTFILES2>FORM-FILE))
|
||||
(TEST.MASTER-MACHINE (QUOTE 222#6#))
|
||||
(TEST.RESULT-FILE-NAME (QUOTE {ERIS}<MARKOVITCH>TESTER>TESTFILES2>RESULT-FILE)))
|
||||
(CONSTANTS (GARY (QUOTE 222#24#))
|
||||
(TERRY (QUOTE 222#53#))
|
||||
(TEST.CHAR-PER-SECOND-PRINTING-SPEED 400)
|
||||
(TEST.CHAR-PER-SECOND-READING-SPEED 1000)
|
||||
(TEST.CHECK-FOR-RESPONSE-PERIOD.ms 100)
|
||||
(TEST.DEFAULT-MAX-WAITING-TIME-ON-FILE.ms 20000)
|
||||
(TEST.DEFAULT-MAX-WAITING-TIME-ON-FLAG.ms 30000)
|
||||
(TEST.GENERAL-DEFAULT-WAITING-TIME.ms 60000)
|
||||
(TEST.MAX-DATA-TRANSFER-TIME.ms 1000)
|
||||
(TEST.OPEN-AND-CLOSE-FILE-TIME.ms 20000)
|
||||
(TEST.PERIOD-BETWEEN-FILE-OPEN-TRIALS.ms 5000)
|
||||
(TEST.PERIOD-BETWEEN-FLAG-CHECK-TRIALS.ms 100)
|
||||
(TEST.WAIT-FOR-SERVICE-TIME.ms 30000))))
|
||||
(DEFINEQ
|
||||
|
||||
(TEST.CALL-SOMEONE-FOR-HELP
|
||||
[LAMBDA (MESS T-ITEM) (* sm "27-Jun-85 11:38")
|
||||
(RINGBELLS)
|
||||
(PROMPTPRINT MESS)
|
||||
(LAFITE.SENDMESSAGE (CONCAT "Subject: Tester program needs help
|
||||
To: Markovitch.pa
|
||||
|
||||
Help -- " MESS))
|
||||
(MENU (create MENU
|
||||
ITEMS _(LIST (LIST T-ITEM T)
|
||||
(QUOTE ("Skip test" NIL)))
|
||||
MENUFONT _ BIGFONT])
|
||||
|
||||
(TEST.ESTIMATE-FILE-PRINTING-TIME
|
||||
[LAMBDA (NUMBER-OF-CHARACTERS) (* sm "27-Jun-85 12:14")
|
||||
(IPLUS TEST.OPEN-AND-CLOSE-FILE-TIME.ms (ITIMES 1000 (FIX (FQUOTIENT NUMBER-OF-CHARACTERS
|
||||
TEST.CHAR-PER-SECOND-PRINTING-SPEED])
|
||||
|
||||
(TEST.ESTIMATE-FILE-READING-TIME
|
||||
[LAMBDA (FORM) (* sm "27-Jun-85 11:48")
|
||||
(IPLUS TEST.OPEN-AND-CLOSE-FILE-TIME.ms (ITIMES 1000 (FIX (FQUOTIENT (NCHARS FORM T)
|
||||
|
||||
TEST.CHAR-PER-SECOND-READING-SPEED])
|
||||
|
||||
(TEST.EVAL-FORM-AT-HOST
|
||||
[LAMBDA NIL (* sm "27-Jun-85 14:53")
|
||||
(PROG (RESULT NUM-OF-CHARS-IN-RESULT FORM)
|
||||
(SETQ FORM TEST.GLOBAL-FORM-IN-HOST-MACHINE)
|
||||
(SETQ RESULT (TEST.LOCAL-EVAL-FORM FORM))
|
||||
(SETQ NUM-OF-CHARS-IN-RESULT (NCHARS RESULT T))
|
||||
(SETQ TEST.GLOBAL-RESULT-IN-HOST-MACHINE RESULT)
|
||||
(REMOTEVAL (LIST (QUOTE SETQ)
|
||||
(QUOTE TEST.COMMUNICATION-FLAG)
|
||||
NUM-OF-CHARS-IN-RESULT)
|
||||
TEST.MASTER-MACHINE 0 TEST.WAIT-FOR-SERVICE-TIME.ms])
|
||||
|
||||
(TEST.FLAG-CONTROLED-REMOTE-EVAL
|
||||
[LAMBDA (FORM HOST MAX-WAITING-TIME.ms) (* sm "27-Jun-85 16:50")
|
||||
(PROG (TRANSACTION-ID ABORT-TRIAL)
|
||||
(if (NULL MAX-WAITING-TIME.ms)
|
||||
then (SETQ MAX-WAITING-TIME.ms TEST.GENERAL-DEFAULT-WAITING-TIME.ms))
|
||||
(SETQ TEST.COMMUNICATION-FLAG NIL)
|
||||
START-AGAIN
|
||||
(SETQ TRANSACTION-ID (TEST.NONE-BREAK-REMOTEVAL FORM HOST 0 TEST.WAIT-FOR-SERVICE-TIME.ms))
|
||||
(if (EQ TRANSACTION-ID (QUOTE TIME-EXPIRED))
|
||||
then [if (TEST.CALL-SOMEONE-FOR-HELP "Can't eastablish communication with eval host. "
|
||||
"Retry communicating")
|
||||
then (GO START-AGAIN)
|
||||
else (RETURN (QUOTE (ERROR! "REMOTE SERVICE DOES NOT RESPONSE"]
|
||||
else (TEST.WAIT-ON-FLAG (QUOTE TEST.COMMUNICATION-FLAG)
|
||||
(IPLUS MAX-WAITING-TIME.ms TEST.MAX-DATA-TRANSFER-TIME.ms))
|
||||
(if (NOT TEST.COMMUNICATION-FLAG)
|
||||
then (SETQ ABORT-TRIAL (TEST.NONE-BREAK-REMOTEVAL (LIST (QUOTE EVALSERVER.ABORT)
|
||||
TRANSACTION-ID)
|
||||
TEST.EVAL-SERVER-HOST 1
|
||||
TEST.WAIT-FOR-SERVICE-TIME.ms))
|
||||
[if (EQ ABORT-TRIAL (QUOTE TIME-EXPIRED))
|
||||
then [if (TEST.CALL-SOMEONE-FOR-HELP
|
||||
"Eval server host did not complete his computation in the designated time, and does not response to interrupt trials."
|
||||
"Retry test")
|
||||
then (RETURN (QUOTE (ERROR! RETRY)))
|
||||
else (RETURN (QUOTE (ERROR! "TIME EXPIRED, ABORT FAILED. "]
|
||||
else (RETURN (QUOTE (ERROR! "TIME EXPIRED, REMOTE ABORTED."]
|
||||
else (RETURN TEST.COMMUNICATION-FLAG])
|
||||
|
||||
(TEST.LOAD-FORM-AND-EVAL
|
||||
[LAMBDA NIL (* sm "27-Jun-85 13:21")
|
||||
(PROG (FORM-FILE RESULT-FILE RESULT FORM NUM-OF-CHARS-IN-RESULT)
|
||||
(SETQ FORM-FILE (TEST.OPEN-INPUT-FILE-OR-WAIT TEST.FORM-FILE-NAME))
|
||||
(IF (TEST.ERRORP FORM-FILE)
|
||||
THEN (SETQ RESULT RESULT-FILE)
|
||||
ELSE (SETQ FORM (READ FORM-FILE))
|
||||
(CLOSEF FORM-FILE)
|
||||
(SETQ RESULT (TEST.LOCAL-EVAL-FORM FORM)))
|
||||
(SETQ NUM-OF-CHARS-IN-RESULT (NCHARS RESULT T))
|
||||
(SETQ TEST.GLOBAL-RESULT-IN-HOST-MACHINE RESULT)
|
||||
(REMOTEVAL (LIST (QUOTE SETQ)
|
||||
(QUOTE TEST.COMMUNICATION-FLAG)
|
||||
NUM-OF-CHARS-IN-RESULT)
|
||||
TEST.MASTER-MACHINE 0 TEST.WAIT-FOR-SERVICE-TIME.ms])
|
||||
|
||||
(TEST.NONE-BREAK-REMOTEVAL
|
||||
[LAMBDA (FORM HOST MULT TIMEOUT) (* sm "26-Jun-85 11:18")
|
||||
(PROG (RESULT OLD-HELPFLAG)
|
||||
(SETQ OLD-HELPFLAG (GETTOPVAL (QUOTE HELPFLAG)))
|
||||
(SETTOPVAL (QUOTE HELPFLAG)
|
||||
NIL)
|
||||
(SETQ RESULT (ERRORSET (QUOTE (REMOTEVAL FORM HOST MULT TIMEOUT))
|
||||
(QUOTE NOBREAK)))
|
||||
[if (NULL RESULT)
|
||||
then (SETQ RESULT (LIST (ERRORN)))
|
||||
(if (EQP (CAAR RESULT)
|
||||
17)
|
||||
then (SETQ RESULT (QUOTE (TIME-EXPIRED]
|
||||
(SETTOPVAL (QUOTE HELPFLAG)
|
||||
OLD-HELPFLAG)
|
||||
(RETURN (CAR RESULT])
|
||||
|
||||
(TEST.OPEN-INPUT-FILE-OR-WAIT
|
||||
[LAMBDA (FILE-NAME MAX-WAITING-TIME.ms) (* sm "27-Jun-85 14:12")
|
||||
(PROG (F)
|
||||
(if (NULL MAX-WAITING-TIME.ms)
|
||||
then (SETQ MAX-WAITING-TIME.ms TEST.DEFAULT-MAX-WAITING-TIME-ON-FILE.ms))
|
||||
(for II from 0 to MAX-WAITING-TIME.ms by TEST.PERIOD-BETWEEN-FILE-OPEN-TRIALS.ms
|
||||
while [TEST.ERRORP (SETQ F (TEST.LOCAL-EVAL-FORM (LIST (QUOTE OPENFILE)
|
||||
(KWOTE FILE-NAME)
|
||||
(QUOTE (QUOTE INPUT))
|
||||
(QUOTE (QUOTE OLD]
|
||||
do (DISMISS TEST.PERIOD-BETWEEN-FILE-OPEN-TRIALS.ms))
|
||||
(RETURN F])
|
||||
|
||||
(TEST.PRINT-RESULT-ON-FILE
|
||||
[LAMBDA NIL (* sm "27-Jun-85 12:47")
|
||||
(PROG (RESULT-FILE)
|
||||
(SETQ RESULT-FILE (OPENFILE TEST.RESULT-FILE-NAME (QUOTE OUTPUT)
|
||||
(QUOTE NEW)))
|
||||
(PRIN4 TEST.GLOBAL-RESULT-IN-HOST-MACHINE RESULT-FILE)
|
||||
(CLOSEF RESULT-FILE)
|
||||
(REMOTEVAL (QUOTE (SETQ TEST.COMMUNICATION-FLAG T))
|
||||
TEST.MASTER-MACHINE 0 TEST.WAIT-FOR-SERVICE-TIME.ms])
|
||||
|
||||
(TEST.READ-FORM-FILE
|
||||
[LAMBDA NIL (* sm "27-Jun-85 16:39")
|
||||
(PROG (FORM-FILE RESULT)
|
||||
(SETQ FORM-FILE (TEST.OPEN-INPUT-FILE-OR-WAIT TEST.FORM-FILE-NAME))
|
||||
(IF (NOT (TEST.ERRORP FORM-FILE))
|
||||
THEN (SETQ TEST.GLOBAL-FORM-IN-HOST-MACHINE (READ FORM-FILE))
|
||||
(CLOSEF FORM-FILE))
|
||||
(REMOTEVAL (LIST (QUOTE SETQ)
|
||||
(QUOTE TEST.COMMUNICATION-FLAG)
|
||||
(KWOTE FORM-FILE))
|
||||
TEST.MASTER-MACHINE 0 TEST.WAIT-FOR-SERVICE-TIME.ms])
|
||||
|
||||
(TEST.REMOTE-EVAL-FORM
|
||||
[LAMBDA (FORM TIMEOUT.ms) (* sm " 9-Jul-85 17:23")
|
||||
(TEST.REMOTE-EVAL-USING-FILE FORM TIMEOUT.ms])
|
||||
|
||||
(TEST.REMOTE-EVAL-USING-FILE
|
||||
[LAMBDA (FORM TIMEOUT.ms) (* sm "27-Jun-85 16:26")
|
||||
(PROG (FORM-FILE RESULT-FILE NUMBER-OF-CHARACTERS-IN-RESULT RESULT READ-REPORT)
|
||||
START-AGAIN
|
||||
(SETQ FORM-FILE (OPENFILE TEST.FORM-FILE-NAME (QUOTE OUTPUT)
|
||||
(QUOTE NEW)))
|
||||
(PRIN4 FORM FORM-FILE)
|
||||
(CLOSEF FORM-FILE)
|
||||
(SETQ READ-REPORT (TEST.FLAG-CONTROLED-REMOTE-EVAL (QUOTE (TEST.READ-FORM-FILE))
|
||||
TEST.EVAL-SERVER-HOST
|
||||
(TEST.ESTIMATE-FILE-READING-TIME FORM)))
|
||||
(if (TEST.ERRORP READ-REPORT)
|
||||
then (if (EQ (CADR READ-REPORT)
|
||||
(QUOTE RETRY))
|
||||
then (GO START-AGAIN)
|
||||
else (RETURN READ-REPORT))
|
||||
else (SETQ NUMBER-OF-CHARACTERS-IN-RESULT (TEST.FLAG-CONTROLED-REMOTE-EVAL
|
||||
(QUOTE (TEST.EVAL-FORM-AT-HOST))
|
||||
TEST.EVAL-SERVER-HOST TIMEOUT.ms))
|
||||
|
||||
(* If Computation Completed Succesfully Then The Communication Flag Was Set To The Number Of Characters In The Prin4
|
||||
Form Of The Result So That We Will Be Able To Estimate How Long Should We Wait For Printing The Result File.
|
||||
Otherwise, We Had Some Error, And <Number-of-characters-in-result> Will Be Of The Form (Error! ...))
|
||||
|
||||
|
||||
(if (TEST.ERRORP NUMBER-OF-CHARACTERS-IN-RESULT)
|
||||
then (if (EQ (CADR NUMBER-OF-CHARACTERS-IN-RESULT)
|
||||
(QUOTE RETRY))
|
||||
then (GO START-AGAIN)
|
||||
else (RETURN NUMBER-OF-CHARACTERS-IN-RESULT))
|
||||
else (SETQ RESULT (TEST.FLAG-CONTROLED-REMOTE-EVAL (QUOTE (
|
||||
TEST.PRINT-RESULT-ON-FILE))
|
||||
TEST.EVAL-SERVER-HOST
|
||||
(
|
||||
TEST.ESTIMATE-FILE-PRINTING-TIME NUMBER-OF-CHARACTERS-IN-RESULT)))
|
||||
(if (TEST.ERRORP RESULT)
|
||||
then (if (EQ (CADR RESULT)
|
||||
(QUOTE RETRY))
|
||||
then (GO START-AGAIN)
|
||||
else (RETURN RESULT))
|
||||
else (SETQ RESULT-FILE (TEST.OPEN-INPUT-FILE-OR-WAIT TEST.RESULT-FILE-NAME))
|
||||
(if (TEST.ERRORP RESULT-FILE)
|
||||
then (RETURN RESULT-FILE)
|
||||
else (SETQ RESULT (READ RESULT-FILE))
|
||||
(CLOSEF RESULT-FILE)
|
||||
(RETURN RESULT])
|
||||
|
||||
(TEST.WAIT-ON-FLAG
|
||||
[LAMBDA (FLAG-NAME MAX-WAITING-TIME.ms) (* sm "27-Jun-85 13:23")
|
||||
(if (NULL MAX-WAITING-TIME.ms)
|
||||
then (SETQ MAX-WAITING-TIME.ms TEST.DEFAULT-MAX-WAITING-TIME-ON-FLAG.ms))
|
||||
(for I from 0 to MAX-WAITING-TIME.ms by TEST.PERIOD-BETWEEN-FLAG-CHECK-TRIALS.ms
|
||||
while (NOT (EVAL FLAG-NAME)) do (DISMISS TEST.PERIOD-BETWEEN-FLAG-CHECK-TRIALS.ms])
|
||||
)
|
||||
|
||||
(RPAQQ TEST.COMMUNICATION-FLAG 3)
|
||||
|
||||
(RPAQQ TEST.GLOBAL-FORM-IN-HOST-MACHINE NIL)
|
||||
|
||||
(RPAQQ TEST.GLOBAL-RESULT-IN-HOST-MACHINE NIL)
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS (TEST.EVAL-SERVER-HOST (QUOTE 222#24#))
|
||||
(TEST.FORM-FILE-NAME (QUOTE {ERIS}<MARKOVITCH>TESTER>TESTFILES2>FORM-FILE))
|
||||
(TEST.MASTER-MACHINE (QUOTE 222#6#))
|
||||
(TEST.RESULT-FILE-NAME (QUOTE {ERIS}<MARKOVITCH>TESTER>TESTFILES2>RESULT-FILE)))
|
||||
)
|
||||
(DECLARE: EVAL@COMPILE
|
||||
|
||||
(RPAQQ GARY 222#24#)
|
||||
|
||||
(RPAQQ TERRY 222#53#)
|
||||
|
||||
(RPAQQ TEST.CHAR-PER-SECOND-PRINTING-SPEED 400)
|
||||
|
||||
(RPAQQ TEST.CHAR-PER-SECOND-READING-SPEED 1000)
|
||||
|
||||
(RPAQQ TEST.CHECK-FOR-RESPONSE-PERIOD.ms 100)
|
||||
|
||||
(RPAQQ TEST.DEFAULT-MAX-WAITING-TIME-ON-FILE.ms 20000)
|
||||
|
||||
(RPAQQ TEST.DEFAULT-MAX-WAITING-TIME-ON-FLAG.ms 30000)
|
||||
|
||||
(RPAQQ TEST.GENERAL-DEFAULT-WAITING-TIME.ms 60000)
|
||||
|
||||
(RPAQQ TEST.MAX-DATA-TRANSFER-TIME.ms 1000)
|
||||
|
||||
(RPAQQ TEST.OPEN-AND-CLOSE-FILE-TIME.ms 20000)
|
||||
|
||||
(RPAQQ TEST.PERIOD-BETWEEN-FILE-OPEN-TRIALS.ms 5000)
|
||||
|
||||
(RPAQQ TEST.PERIOD-BETWEEN-FLAG-CHECK-TRIALS.ms 100)
|
||||
|
||||
(RPAQQ TEST.WAIT-FOR-SERVICE-TIME.ms 30000)
|
||||
|
||||
(CONSTANTS (GARY (QUOTE 222#24#))
|
||||
(TERRY (QUOTE 222#53#))
|
||||
(TEST.CHAR-PER-SECOND-PRINTING-SPEED 400)
|
||||
(TEST.CHAR-PER-SECOND-READING-SPEED 1000)
|
||||
(TEST.CHECK-FOR-RESPONSE-PERIOD.ms 100)
|
||||
(TEST.DEFAULT-MAX-WAITING-TIME-ON-FILE.ms 20000)
|
||||
(TEST.DEFAULT-MAX-WAITING-TIME-ON-FLAG.ms 30000)
|
||||
(TEST.GENERAL-DEFAULT-WAITING-TIME.ms 60000)
|
||||
(TEST.MAX-DATA-TRANSFER-TIME.ms 1000)
|
||||
(TEST.OPEN-AND-CLOSE-FILE-TIME.ms 20000)
|
||||
(TEST.PERIOD-BETWEEN-FILE-OPEN-TRIALS.ms 5000)
|
||||
(TEST.PERIOD-BETWEEN-FLAG-CHECK-TRIALS.ms 100)
|
||||
(TEST.WAIT-FOR-SERVICE-TIME.ms 30000))
|
||||
)
|
||||
(PUTPROPS TEST-REMOTE-EVAL COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (1721 11388 (TEST.CALL-SOMEONE-FOR-HELP 1731 . 2150) (TEST.ESTIMATE-FILE-PRINTING-TIME
|
||||
2152 . 2441) (TEST.ESTIMATE-FILE-READING-TIME 2443 . 2740) (TEST.EVAL-FORM-AT-HOST 2742 . 3339) (
|
||||
TEST.FLAG-CONTROLED-REMOTE-EVAL 3341 . 5112) (TEST.LOAD-FORM-AND-EVAL 5114 . 5924) (
|
||||
TEST.NONE-BREAK-REMOTEVAL 5926 . 6639) (TEST.OPEN-INPUT-FILE-OR-WAIT 6641 . 7338) (
|
||||
TEST.PRINT-RESULT-ON-FILE 7340 . 7838) (TEST.READ-FORM-FILE 7840 . 8419) (TEST.REMOTE-EVAL-FORM 8421
|
||||
. 8592) (TEST.REMOTE-EVAL-USING-FILE 8594 . 10934) (TEST.WAIT-ON-FLAG 10936 . 11386)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/TEST-REMOTE-EVAL.LCOM
Normal file
BIN
internal/test/tools/TEST-REMOTE-EVAL.LCOM
Normal file
Binary file not shown.
2180
internal/test/tools/TESTER
Normal file
2180
internal/test/tools/TESTER
Normal file
File diff suppressed because it is too large
Load Diff
0
internal/test/tools/TESTER.LCOM
Normal file
0
internal/test/tools/TESTER.LCOM
Normal file
97
internal/test/tools/TESTER.TEDIT
Normal file
97
internal/test/tools/TESTER.TEDIT
Normal file
File diff suppressed because one or more lines are too long
47
internal/test/tools/TESTERLOADER
Normal file
47
internal/test/tools/TESTERLOADER
Normal file
@@ -0,0 +1,47 @@
|
||||
(FILECREATED " 2-Oct-86 16:51:12" {ERINYES}<TEST>TOOLS>TESTERLOADER.;3 1750
|
||||
|
||||
previous date: "19-Aug-85 16:19:15" {DSK}<LISPFILES>TESTER>SOURCES>TESTERLOADER.;2)
|
||||
|
||||
|
||||
(* Copyright (c) 1986 by XEROX Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TESTERLOADERCOMS)
|
||||
|
||||
(RPAQQ TESTERLOADERCOMS ((INITVARS TEST.DIRECTORY NIL)
|
||||
(P [IF (NULL TEST.DIRECTORY)
|
||||
THEN
|
||||
(CLRPROMPT)
|
||||
(SETQ TEST.DIRECTORY (MKATOM (PROMPTFORWORD
|
||||
"Enter name of directory in which TESTER files are located :"
|
||||
(DIRECTORYNAME T T)
|
||||
NIL PROMPTWINDOW NIL
|
||||
(QUOTE TTY]
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE VARBROWSER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE THERMOMETER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TESTER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TESTERVARS)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE RANDOM-GENERATOR.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TEST-REMOTE-EVAL.DCOM)))
|
||||
(TEST.INIT))))
|
||||
|
||||
(RPAQ? TEST.DIRECTORY NIL)
|
||||
|
||||
(RPAQ? NIL NIL)
|
||||
[IF (NULL TEST.DIRECTORY)
|
||||
THEN
|
||||
(CLRPROMPT)
|
||||
(SETQ TEST.DIRECTORY (MKATOM (PROMPTFORWORD
|
||||
"Enter name of directory in which TESTER files are located :"
|
||||
(DIRECTORYNAME T T)
|
||||
NIL PROMPTWINDOW NIL (QUOTE TTY]
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE VARBROWSER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE THERMOMETER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TESTER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TESTERVARS)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE RANDOM-GENERATOR.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TEST-REMOTE-EVAL.DCOM)))
|
||||
(TEST.INIT)
|
||||
(PUTPROPS TESTERLOADER COPYRIGHT ("XEROX Corporation" 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
27
internal/test/tools/TESTERLOADER.LCOM
Normal file
27
internal/test/tools/TESTERLOADER.LCOM
Normal file
@@ -0,0 +1,27 @@
|
||||
(FILECREATED "24-Oct-2020 22:17:36" ("compiled on "
|
||||
{DSK}<home>larry>ilisp>ENVOS>MISC>TEST>Tools>TESTERLOADER.;1) " 9-Apr-2000 18:01:32" bcompl'd in
|
||||
"Medley 3.5 PARC Full Sysout 4-Nov-2003 ..." dated " 4-Nov-2003 23:32:48")
|
||||
(FILECREATED " 2-Oct-86 16:51:12" {ERINYES}<TEST>TOOLS>TESTERLOADER.;3 1750 previous date:
|
||||
"19-Aug-85 16:19:15" {DSK}<LISPFILES>TESTER>SOURCES>TESTERLOADER.;2)
|
||||
(PRETTYCOMPRINT TESTERLOADERCOMS)
|
||||
(RPAQQ TESTERLOADERCOMS ((INITVARS TEST.DIRECTORY NIL) (P (IF (NULL TEST.DIRECTORY) THEN (CLRPROMPT) (
|
||||
SETQ TEST.DIRECTORY (MKATOM (PROMPTFORWORD
|
||||
"Enter name of directory in which TESTER files are located :" (DIRECTORYNAME T T) NIL PROMPTWINDOW NIL
|
||||
(QUOTE TTY))))) (LOAD? (PACK* TEST.DIRECTORY (QUOTE VARBROWSER.DCOM))) (LOAD? (PACK* TEST.DIRECTORY (
|
||||
QUOTE THERMOMETER.DCOM))) (LOAD? (PACK* TEST.DIRECTORY (QUOTE TESTER.DCOM))) (LOAD? (PACK*
|
||||
TEST.DIRECTORY (QUOTE TESTERVARS))) (LOAD? (PACK* TEST.DIRECTORY (QUOTE RANDOM-GENERATOR.DCOM))) (
|
||||
LOAD? (PACK* TEST.DIRECTORY (QUOTE TEST-REMOTE-EVAL.DCOM))) (TEST.INIT))))
|
||||
(RPAQ? TEST.DIRECTORY NIL)
|
||||
(RPAQ? NIL NIL)
|
||||
(IF (NULL TEST.DIRECTORY) THEN (CLRPROMPT) (SETQ TEST.DIRECTORY (MKATOM (PROMPTFORWORD
|
||||
"Enter name of directory in which TESTER files are located :" (DIRECTORYNAME T T) NIL PROMPTWINDOW NIL
|
||||
(QUOTE TTY)))))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE VARBROWSER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE THERMOMETER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TESTER.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TESTERVARS)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE RANDOM-GENERATOR.DCOM)))
|
||||
(LOAD? (PACK* TEST.DIRECTORY (QUOTE TEST-REMOTE-EVAL.DCOM)))
|
||||
(TEST.INIT)
|
||||
(PUTPROPS TESTERLOADER COPYRIGHT ("XEROX Corporation" 1986))
|
||||
NIL
|
||||
347
internal/test/tools/TESTERVARS
Normal file
347
internal/test/tools/TESTERVARS
Normal file
@@ -0,0 +1,347 @@
|
||||
(FILECREATED "21-Aug-85 16:44:54" {DSK}<LISPFILES>TESTER>SOURCES>TESTERVARS.;10 14034
|
||||
|
||||
changes to: (VARS TEST.CONCEPT-WINDOW-MENU-ITEMS TESTERVARSCOMS TEST.DEFAULT-TRACE-MODE
|
||||
TEST.DEFAULT-PRETEST-MODE TEST.DEFAULT-HARDCOPY-MODE TEST.DEFAULT-LOCATION
|
||||
TEST.MAX-TESTS-BUFFER-SIZE)
|
||||
|
||||
previous date: "20-Aug-85 12:37:12" {DSK}<LISPFILES>TESTER>SOURCES>TESTERVARS.;6)
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TESTERVARSCOMS)
|
||||
|
||||
(RPAQQ TESTERVARSCOMS ((RECORDS CONCEPT CONCEPTSPACE TEST)
|
||||
(VARS TEST.AVERAGE-TEST-SIZE TEST.BACKGROUND-MENU-SUBITEMS TEST.CONCEPT-SPACES
|
||||
TEST.CONCEPT-WINDOW-MENU-ITEMS TEST.DEFAULT-DEPTH TEST.DEFAULT-HARDCOPY-DEVICE
|
||||
TEST.DEFAULT-HARDCOPY-MODE TEST.DEFAULT-LOCATION TEST.DEFAULT-PRETEST-MODE
|
||||
TEST.DEFAULT-TRACE-MODE TEST.DEFAULT.EVALAFTER TEST.DEFAULT.EVALBEFORE
|
||||
TEST.DEFAULT.EVALEXPR TEST.DEFAULT.INPUT TEST.DEFAULT.PRETESTS
|
||||
TEST.DEFAULT.SUCCESSPREDICATE TEST.DEFAULT.TESTCOMMENT TEST.DEFAULT.TESTID
|
||||
TEST.DEFAULT.TIMEOUT TEST.DEFAULT.TIMES TEST.EVAL-SERVER-HOST (
|
||||
TEST.GLOBAL-RESULT-OF-TIMED-EVALUATION NIL)
|
||||
(TEST.LIST-OF-MODIFIED-TESTS NIL)
|
||||
(TEST.LIST-OF-TESTS NIL)
|
||||
TEST.MAX-TESTS-BUFFER-SIZE TEST.MIN-TESTS-BUFFER-SIZE (
|
||||
TEST.NEWPAGE-BEFORE-HARDCOPY-TEST NIL)
|
||||
(TEST.TESTS-BUFFER-SIZE (TEST.SET-TESTS-BUFFER-SIZE)))
|
||||
(INITVARS (TEST.DEFAULT-CONCEPT-SPACE-NAME (QUOTE INTERLISPD-SYSTEM))
|
||||
(TEST.DEFAULT-LOCATION (QUOTE On))
|
||||
(TEST.DISPLAY-THERMOMETERS T)
|
||||
(TEST.OBTAIN-LOCK-WHEN-EDIT T)
|
||||
(TEST.TEST-DATA-BASE-DIRECTORY (QUOTE {ERIS}<TEST>TESTS>))
|
||||
(TEST.TRACE-FILE-NAME (QUOTE {DSK}<LISPFILES>TESTER-TRACES>TRACE-FILE)))
|
||||
(CONSTANTS (TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID (QUOTE {ERIS}<TEST>TOOLS>NEXTID))
|
||||
(TEST.NAME-OF-LOCK-FILE (QUOTE {ERIS}<TEST>TOOLS>LOCK-FILE)))
|
||||
(GLOBALVARS TEST.AVERAGE-TEST-SIZE TEST.BACKGROUND-MENU-SUBITEMS TEST.CONCEPT-SPACES
|
||||
TEST.CONCEPT-WINDOW-MENU-ITEMS TEST.DEFAULT-CONCEPT-SPACE-NAME TEST.DEFAULT-DEPTH
|
||||
TEST.DEFAULT-HARDCOPY-DEVICE TEST.DEFAULT-HARDCOPY-MODE TEST.DEFAULT-LOCATION
|
||||
TEST.DEFAULT-PRETEST-MODE TEST.DEFAULT-TRACE-MODE TEST.DEFAULT.EVALAFTER
|
||||
TEST.DEFAULT.EVALBEFORE TEST.DEFAULT.EVALEXPR TEST.DEFAULT.INPUT
|
||||
TEST.DEFAULT.PRETESTS TEST.DEFAULT.SUCCESSPREDICATE TEST.DEFAULT.TESTCOMMENT
|
||||
TEST.DEFAULT.TESTID TEST.DEFAULT.TIMEOUT TEST.DEFAULT.TIMES
|
||||
TEST.DISPLAY-THERMOMETERS TEST.EVAL-SERVER-HOST
|
||||
TEST.GLOBAL-RESULT-OF-TIMED-EVALUATION TEST.LIST-OF-MODIFIED-TESTS
|
||||
TEST.LIST-OF-TESTS TEST.MAX-TESTS-BUFFER-SIZE TEST.MIN-TESTS-BUFFER-SIZE
|
||||
TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID TEST.NAME-OF-LOCK-FILE
|
||||
TEST.NEWPAGE-BEFORE-HARDCOPY-TEST TEST.OBTAIN-LOCK-WHEN-EDIT
|
||||
TEST.TEST-DATA-BASE-DIRECTORY TEST.TESTS-BUFFER-SIZE TEST.TRACE-FILE-NAME)
|
||||
(P (VARBROWSER [QUOTE ((TEST.EVAL-SERVER-HOST)
|
||||
(TEST.TEST-DATA-BASE-DIRECTORY)
|
||||
(TEST.DEFAULT-HARDCOPY-DEVICE)
|
||||
(TEST.TRACE-FILE-NAME)
|
||||
(TEST.DEFAULT-HARDCOPY-MODE (No-Hardcopy Failures-Only Hardcopy-All))
|
||||
(TEST.DEFAULT-PRETEST-MODE (No-Pretests Weak-Links Strong-Links))
|
||||
(TEST.DEFAULT-TRACE-MODE (On Off))
|
||||
(TEST.DEFAULT-LOCATION (Local Remote))
|
||||
(TEST.TRACE-FILE-NAME)
|
||||
(TEST.DEFAULT-CONCEPT-SPACE-NAME)
|
||||
(TEST.DEFAULT-DEPTH (NIL 2 3 4 5 6 7 8 9 10))
|
||||
(TEST.MAX-TESTS-BUFFER-SIZE (2000 1000 750 500 250 200 100 75 50 30 10)
|
||||
)
|
||||
(TEST.MIN-TESTS-BUFFER-SIZE (1 5 10 20 50 100 200 500))
|
||||
(TEST.OBTAIN-LOCK-WHEN-EDIT (T NIL))
|
||||
(TEST.DISPLAY-THERMOMETERS (T NIL))
|
||||
(TEST.NEWPAGE-BEFORE-HARDCOPY-TEST (T NIL]
|
||||
NIL "Test Variables"))))
|
||||
[DECLARE: EVAL@COMPILE
|
||||
|
||||
(RECORD CONCEPT (CONCEPTNAME TESTS SUBCONCEPTS SUPERCONCEPTS))
|
||||
|
||||
(RECORD CONCEPTSPACE (CONCEPTSPACENAME ROOTCONCEPT CONCEPTLIST))
|
||||
|
||||
(RECORD TEST (TESTID EVALEXPR INPUT SUCCESSPREDICATE TIMES TIMEOUT EVALBEFORE EVALAFTER TESTCOMMENT
|
||||
PRETESTS))
|
||||
]
|
||||
|
||||
(RPAQQ TEST.AVERAGE-TEST-SIZE 1.222222)
|
||||
|
||||
(RPAQQ TEST.BACKGROUND-MENU-SUBITEMS (SUBITEMS ("Load Concept Space" (TEST.LOAD-CONCEPT-SPACE-COMMAND)
|
||||
|
||||
"Prompts for a file name and loads the concept space stored on this file.")
|
||||
("Store Concept Space" (
|
||||
TEST.STORE-CONCEPT-SPACE-COMMAND)
|
||||
|
||||
"Pops up a menu of the concept spaces, prompts for a file name and stores the concept space on the file."
|
||||
)
|
||||
("Browse concept space" (
|
||||
TEST.BROWSE-CONCEPT-SPACE-COMMAND)
|
||||
|
||||
"Pops up a menu of the concept spaces, and displayes a graph window of the selected concept space.")))
|
||||
|
||||
(RPAQQ TEST.CONCEPT-SPACES [(INTERLISPD-SYSTEM INTERLISP-D
|
||||
((INTERLISP-D NIL (TESTER INPUT/OUTPUT DISPLAY
|
||||
COMPILER LIST-PROCESSING
|
||||
ARITHMETIC)
|
||||
NIL)
|
||||
(ARITHMETIC NIL (ARITHMETIC-FUNCTIONS
|
||||
FLOAT-ARITHMETIC
|
||||
INTEGER-ARITHMETIC)
|
||||
(INTERLISP-D))
|
||||
(LIST-PROCESSING NIL NIL (INTERLISP-D))
|
||||
(COMPILER NIL NIL (INTERLISP-D))
|
||||
(INTEGER-ARITHMETIC NIL
|
||||
(IQUOTIENT IMINUS IPLUS ITIMES
|
||||
BIGNUM FIXP-ARITH)
|
||||
(ARITHMETIC))
|
||||
(FLOAT-ARITHMETIC NIL (FTIMES FPLUS)
|
||||
(ARITHMETIC))
|
||||
(FIXP-ARITH (10 8 7 6 5)
|
||||
NIL
|
||||
(INTEGER-ARITHMETIC))
|
||||
(BIGNUM (27 26 25 24 23 20 18 13 12 11 9 4)
|
||||
NIL
|
||||
(INTEGER-ARITHMETIC))
|
||||
(ARITHMETIC-FUNCTIONS NIL
|
||||
(IQUOTIENT SUB1 ADD1 IMINUS EQP
|
||||
FTIMES FPLUS IPLUS
|
||||
ITIMES)
|
||||
(ARITHMETIC))
|
||||
(ITIMES (13 10 4)
|
||||
NIL
|
||||
(INTEGER-ARITHMETIC ARITHMETIC-FUNCTIONS))
|
||||
(IPLUS (12 11 9 8 7 6 5)
|
||||
NIL
|
||||
(INTEGER-ARITHMETIC ARITHMETIC-FUNCTIONS))
|
||||
(FPLUS NIL NIL (FLOAT-ARITHMETIC ARITHMETIC-FUNCTIONS)
|
||||
)
|
||||
(FTIMES NIL NIL (FLOAT-ARITHMETIC
|
||||
ARITHMETIC-FUNCTIONS))
|
||||
(DISPLAY NIL (FONTS WINDOW-SYSTEM)
|
||||
(INTERLISP-D))
|
||||
(WINDOW-SYSTEM NIL (WINDOW-FUNCTIONS)
|
||||
(DISPLAY))
|
||||
(WINDOW-FUNCTIONS NIL (SHAPEW)
|
||||
(WINDOW-SYSTEM))
|
||||
(SHAPEW (14)
|
||||
NIL
|
||||
(WINDOW-FUNCTIONS))
|
||||
(FONTS NIL (FONTS-FUNCTIONS)
|
||||
(DISPLAY))
|
||||
(FONTS-FUNCTIONS NIL (FONTCREATE)
|
||||
(FONTS))
|
||||
(FONTCREATE (16)
|
||||
NIL
|
||||
(I/O-FUNCTIONS FONTS-FUNCTIONS))
|
||||
(INPUT/OUTPUT NIL (I/O-FUNCTIONS DSK-FILING NS-FILING)
|
||||
(INTERLISP-D))
|
||||
(NS-FILING (3 2 1)
|
||||
NIL
|
||||
(INPUT/OUTPUT))
|
||||
(DSK-FILING NIL NIL (INPUT/OUTPUT))
|
||||
(I/O-FUNCTIONS NIL (FONTCREATE PRIN2 READ)
|
||||
(INPUT/OUTPUT))
|
||||
(READ (3 2 1)
|
||||
NIL
|
||||
(I/O-FUNCTIONS))
|
||||
(PRIN2 (3 2 1)
|
||||
NIL
|
||||
(I/O-FUNCTIONS))
|
||||
(TESTER NIL (RANDOM-GENERATOR TESTS REMOTE-EVAL
|
||||
CONCEPT-SPACE)
|
||||
(INTERLISP-D))
|
||||
(CONCEPT-SPACE NIL NIL (TESTER))
|
||||
(REMOTE-EVAL NIL NIL (TESTER))
|
||||
(TESTS NIL (1-100)
|
||||
(TESTER))
|
||||
(RANDOM-GENERATOR NIL NIL (TESTER))
|
||||
(1-100 (21 19)
|
||||
NIL
|
||||
(TESTS))
|
||||
(EQP (20)
|
||||
NIL
|
||||
(ARITHMETIC-FUNCTIONS))
|
||||
(IMINUS (24 23)
|
||||
NIL
|
||||
(INTEGER-ARITHMETIC ARITHMETIC-FUNCTIONS))
|
||||
(ADD1 (26 25)
|
||||
NIL
|
||||
(ARITHMETIC-FUNCTIONS))
|
||||
(SUB1 (26 25)
|
||||
NIL
|
||||
(ARITHMETIC-FUNCTIONS))
|
||||
(IQUOTIENT (27)
|
||||
NIL
|
||||
(INTEGER-ARITHMETIC ARITHMETIC-FUNCTIONS])
|
||||
|
||||
(RPAQQ TEST.CONCEPT-WINDOW-MENU-ITEMS [("Copy subtree" TEST.COPY-SUBTREE-COMMAND)
|
||||
("Add concept" TEST.ADD-CONCEPT-COMMAND)
|
||||
("Delete concept" TEST.DELETE-CONCEPT-COMMAND)
|
||||
("Add link" TEST.ADD-LINK-COMMAND)
|
||||
("Delete link" TEST.DELETE-LINK-COMMAND)
|
||||
("Add test" TEST.ADD-TEST-COMMAND)
|
||||
("Delete test" TEST.DELETE-TEST-COMMAND)
|
||||
("Edit test" TEST.EDIT-TEST-COMMAND)
|
||||
("Display" NIL "select subitem to perform display operations."
|
||||
(SUBITEMS ("Display tests on/off"
|
||||
TEST.SWITCH-DISPLAY-MODE-COMMAND)
|
||||
("Browse subtree"
|
||||
TEST.BROWSE-SUBTREE-COMMAND
|
||||
"Asks for a node selection and creates a browser for the concept space for which the selected node is the root"
|
||||
)
|
||||
("Change depth" TEST.CHANGE-DEPTH-COMMAND
|
||||
"Will prompt for an integer which will be the new depth of the displayed concept space lattice")
|
||||
("Update" TEST.UPDATE-COMMAND
|
||||
"Recomputes the graph and display it.")))
|
||||
("Execute tests" TEST.EXECUTE-TESTS
|
||||
"Executes all the tests of the selected concept. "
|
||||
(SUBITEMS ("All tests" TEST.EXECUTE-TESTS
|
||||
"Executes all the tests of the selected concept. ")
|
||||
("Selected tests"
|
||||
TEST.EXECUTE-SELECTED-TESTS-COMMAND
|
||||
"Lets the user to select tests of the selected concept, and executes these tests.")))
|
||||
("Hardcopy tests" TEST.HARDCOPY-ALL-TESTS-COMMAND NIL
|
||||
(SUBITEMS ("All tests"
|
||||
TEST.HARDCOPY-ALL-TESTS-COMMAND)
|
||||
("Selected tests"
|
||||
TEST.HARDCOPY-SELECTED-TESTS-COMMAND)))
|
||||
("data base" NIL "Select on of the submenus"
|
||||
(SUBITEMS ("Obtain Lock" TEST.OBTAIN-LOCK-COMMAND
|
||||
"Will try to obtain locks on all the tests of the selected concept"
|
||||
(SUBITEMS ("All tests"
|
||||
|
||||
TEST.OBTAIN-LOCK-COMMAND
|
||||
"Will try to obtain locks on all the tests of the selected concept")
|
||||
(
|
||||
"Selected tests" TEST.OBTAIN-LOCK-ON-SELECTED-TESTS-COMMAND
|
||||
"Will try to obtain locks on the selected tests of the selected concept")))
|
||||
("Release lock"
|
||||
TEST.RELEASE-LOCK-COMMAND
|
||||
"Will release all the locks that the user has on the tests of the selected test."
|
||||
(SUBITEMS ("All tests"
|
||||
|
||||
TEST.RELEASE-LOCK-COMMAND
|
||||
"Will release all the locks that the user has on the tests of the selected test.")
|
||||
(
|
||||
"Selected tests" TEST.RELEASE-LOCK-ON-SELECTED-TESTS-COMMAND
|
||||
"Will the locks that the user has on the selected tests of the selected concept"])
|
||||
|
||||
(RPAQQ TEST.DEFAULT-DEPTH NIL)
|
||||
|
||||
(RPAQQ TEST.DEFAULT-HARDCOPY-DEVICE {LPT})
|
||||
|
||||
(RPAQQ TEST.DEFAULT-HARDCOPY-MODE Hardcopy-All)
|
||||
|
||||
(RPAQQ TEST.DEFAULT-LOCATION Local)
|
||||
|
||||
(RPAQQ TEST.DEFAULT-PRETEST-MODE Weak-Links)
|
||||
|
||||
(RPAQQ TEST.DEFAULT-TRACE-MODE On)
|
||||
|
||||
(RPAQQ TEST.DEFAULT.EVALAFTER [LAMBDA (RES ARGS])
|
||||
|
||||
(RPAQQ TEST.DEFAULT.EVALBEFORE NIL)
|
||||
|
||||
(RPAQQ TEST.DEFAULT.EVALEXPR NIL)
|
||||
|
||||
(RPAQQ TEST.DEFAULT.INPUT (QUOTE DUMMYARG1 DUMMYARG2))
|
||||
|
||||
(RPAQQ TEST.DEFAULT.PRETESTS ((WEAK)
|
||||
(STRONG)))
|
||||
|
||||
(RPAQQ TEST.DEFAULT.SUCCESSPREDICATE [LAMBDA (RES ARGS)
|
||||
(IF THEN (QUOTE SUCCESS)
|
||||
ELSE
|
||||
(QUOTE FAILURE])
|
||||
|
||||
(RPAQQ TEST.DEFAULT.TESTCOMMENT (* * Describe in short what the test does))
|
||||
|
||||
(RPAQQ TEST.DEFAULT.TESTID 0)
|
||||
|
||||
(RPAQQ TEST.DEFAULT.TIMEOUT [LAMBDA (ARGS)
|
||||
1000])
|
||||
|
||||
(RPAQQ TEST.DEFAULT.TIMES 1)
|
||||
|
||||
(RPAQQ TEST.EVAL-SERVER-HOST NIL)
|
||||
|
||||
(RPAQQ TEST.GLOBAL-RESULT-OF-TIMED-EVALUATION NIL)
|
||||
|
||||
(RPAQQ TEST.LIST-OF-MODIFIED-TESTS NIL)
|
||||
|
||||
(RPAQQ TEST.LIST-OF-TESTS NIL)
|
||||
|
||||
(RPAQQ TEST.MAX-TESTS-BUFFER-SIZE 500)
|
||||
|
||||
(RPAQQ TEST.MIN-TESTS-BUFFER-SIZE 20)
|
||||
|
||||
(RPAQQ TEST.NEWPAGE-BEFORE-HARDCOPY-TEST NIL)
|
||||
|
||||
(RPAQ TEST.TESTS-BUFFER-SIZE (TEST.SET-TESTS-BUFFER-SIZE))
|
||||
|
||||
(RPAQ? TEST.DEFAULT-CONCEPT-SPACE-NAME (QUOTE INTERLISPD-SYSTEM))
|
||||
|
||||
(RPAQ? TEST.DEFAULT-LOCATION (QUOTE On))
|
||||
|
||||
(RPAQ? TEST.DISPLAY-THERMOMETERS T)
|
||||
|
||||
(RPAQ? TEST.OBTAIN-LOCK-WHEN-EDIT T)
|
||||
|
||||
(RPAQ? TEST.TEST-DATA-BASE-DIRECTORY (QUOTE {ERIS}<TEST>TESTS>))
|
||||
|
||||
(RPAQ? TEST.TRACE-FILE-NAME (QUOTE {DSK}<LISPFILES>TESTER-TRACES>TRACE-FILE))
|
||||
(DECLARE: EVAL@COMPILE
|
||||
|
||||
(RPAQQ TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID {ERIS}<TEST>TOOLS>NEXTID)
|
||||
|
||||
(RPAQQ TEST.NAME-OF-LOCK-FILE {ERIS}<TEST>TOOLS>LOCK-FILE)
|
||||
|
||||
(CONSTANTS (TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID (QUOTE {ERIS}<TEST>TOOLS>NEXTID))
|
||||
(TEST.NAME-OF-LOCK-FILE (QUOTE {ERIS}<TEST>TOOLS>LOCK-FILE)))
|
||||
)
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS TEST.AVERAGE-TEST-SIZE TEST.BACKGROUND-MENU-SUBITEMS TEST.CONCEPT-SPACES
|
||||
TEST.CONCEPT-WINDOW-MENU-ITEMS TEST.DEFAULT-CONCEPT-SPACE-NAME TEST.DEFAULT-DEPTH
|
||||
TEST.DEFAULT-HARDCOPY-DEVICE TEST.DEFAULT-HARDCOPY-MODE TEST.DEFAULT-LOCATION
|
||||
TEST.DEFAULT-PRETEST-MODE TEST.DEFAULT-TRACE-MODE TEST.DEFAULT.EVALAFTER
|
||||
TEST.DEFAULT.EVALBEFORE TEST.DEFAULT.EVALEXPR TEST.DEFAULT.INPUT TEST.DEFAULT.PRETESTS
|
||||
TEST.DEFAULT.SUCCESSPREDICATE TEST.DEFAULT.TESTCOMMENT TEST.DEFAULT.TESTID
|
||||
TEST.DEFAULT.TIMEOUT TEST.DEFAULT.TIMES TEST.DISPLAY-THERMOMETERS TEST.EVAL-SERVER-HOST
|
||||
TEST.GLOBAL-RESULT-OF-TIMED-EVALUATION TEST.LIST-OF-MODIFIED-TESTS TEST.LIST-OF-TESTS
|
||||
TEST.MAX-TESTS-BUFFER-SIZE TEST.MIN-TESTS-BUFFER-SIZE
|
||||
TEST.NAME-OF-FILE-HOLDING-NEXT-TESTID TEST.NAME-OF-LOCK-FILE
|
||||
TEST.NEWPAGE-BEFORE-HARDCOPY-TEST TEST.OBTAIN-LOCK-WHEN-EDIT
|
||||
TEST.TEST-DATA-BASE-DIRECTORY TEST.TESTS-BUFFER-SIZE TEST.TRACE-FILE-NAME)
|
||||
)
|
||||
(VARBROWSER [QUOTE ((TEST.EVAL-SERVER-HOST)
|
||||
(TEST.TEST-DATA-BASE-DIRECTORY)
|
||||
(TEST.DEFAULT-HARDCOPY-DEVICE)
|
||||
(TEST.TRACE-FILE-NAME)
|
||||
(TEST.DEFAULT-HARDCOPY-MODE (No-Hardcopy Failures-Only Hardcopy-All))
|
||||
(TEST.DEFAULT-PRETEST-MODE (No-Pretests Weak-Links Strong-Links))
|
||||
(TEST.DEFAULT-TRACE-MODE (On Off))
|
||||
(TEST.DEFAULT-LOCATION (Local Remote))
|
||||
(TEST.TRACE-FILE-NAME)
|
||||
(TEST.DEFAULT-CONCEPT-SPACE-NAME)
|
||||
(TEST.DEFAULT-DEPTH (NIL 2 3 4 5 6 7 8 9 10))
|
||||
(TEST.MAX-TESTS-BUFFER-SIZE (2000 1000 750 500 250 200 100 75 50 30 10))
|
||||
(TEST.MIN-TESTS-BUFFER-SIZE (1 5 10 20 50 100 200 500))
|
||||
(TEST.OBTAIN-LOCK-WHEN-EDIT (T NIL))
|
||||
(TEST.DISPLAY-THERMOMETERS (T NIL))
|
||||
(TEST.NEWPAGE-BEFORE-HARDCOPY-TEST (T NIL]
|
||||
NIL "Test Variables")
|
||||
(PUTPROPS TESTERVARS COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
BIN
internal/test/tools/TESTERVARS.DFASL
Normal file
BIN
internal/test/tools/TESTERVARS.DFASL
Normal file
Binary file not shown.
147
internal/test/tools/TESTEXEC
Normal file
147
internal/test/tools/TESTEXEC
Normal file
@@ -0,0 +1,147 @@
|
||||
(FILECREATED "23-Sep-85 15:38:40" {DANTE}<SVERNON>TESTEXEC.;8 5415
|
||||
|
||||
changes to: (FNS ADD-TO-TEST-SUITE END-TEST-BLOCK)
|
||||
|
||||
previous date: "20-Sep-85 10:12:37" {DANTE}<SVERNON>TESTEXEC.;7)
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by XEROX Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TESTEXECCOMS)
|
||||
|
||||
(RPAQQ TESTEXECCOMS [(LISPXMACROS ET ITR ITS ST)
|
||||
(VARS (TEST-SUITE-DATA NIL))
|
||||
(FNS ADD-TO-TEST-SUITE END-TEST-BLOCK EXECUTE-TEST EXECUTE-TEST-GUTS
|
||||
EXECUTE-TEST-SUITE START-TEST-BLOCK TESTEXEC)
|
||||
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
(NLAML ADD-TO-TEST-SUITE)
|
||||
(LAMA])
|
||||
|
||||
(ADDTOVAR LISPXMACROS (ET (END-TEST-BLOCK LISPXLINE))
|
||||
(ITR (NILL))
|
||||
(ITS (NILL))
|
||||
(ST (START-TEST-BLOCK)))
|
||||
|
||||
(RPAQQ TEST-SUITE-DATA NIL)
|
||||
(DEFINEQ
|
||||
|
||||
(ADD-TO-TEST-SUITE
|
||||
[NLAMBDA (SUITE-NAME) (* edited: "23-Sep-85 15:34")
|
||||
[SETQ SUITE-NAME (CAR (NLAMBDA.ARGS (CONS SUITE-NAME NIL]
|
||||
(if (AND SUITE-NAME (LITATOM SUITE-NAME))
|
||||
then [OR [AND (BOUNDP SUITE-NAME)
|
||||
(OR (LISTP (EVALV SUITE-NAME))
|
||||
(NULL (EVALV SUITE-NAME]
|
||||
(PROG1 (SET SUITE-NAME NIL)
|
||||
(MARKASCHANGED SUITE-NAME (QUOTE VARS)
|
||||
(if (BOUNDP SUITE-NAME)
|
||||
then (QUOTE CHANGED)
|
||||
else (QUOTE DEFINED]
|
||||
(SETQ TEST-SUITE-DATA SUITE-NAME)
|
||||
(SETQ TEST-BLOCK-START (CAAR LISPXHISTORY))
|
||||
SUITE-NAME
|
||||
else (ERROR SUITE-NAME "bad suite name"])
|
||||
|
||||
(END-TEST-BLOCK
|
||||
[LAMBDA (TEST-NAME) (* edited: "23-Sep-85 15:35")
|
||||
(if (AND (LISTP TEST-NAME)
|
||||
(LITATOM (CAR TEST-NAME))
|
||||
(EQP (LENGTH TEST-NAME)
|
||||
1))
|
||||
then (if TEST-SUITE-DATA
|
||||
then (PROG (COMMAND-LIST TEST-COMMANDS)
|
||||
(SETQ COMMAND-LIST (for I in (CDAR LISPXHISTORY) until (EQ I
|
||||
TEST-BLOCK-START)
|
||||
collect (COPY I)))
|
||||
[SETQ TEST-COMMANDS
|
||||
(CONS (CAR TEST-NAME)
|
||||
(REVERSE (for I on COMMAND-LIST
|
||||
collect
|
||||
(PROGN [if (AND (EQ (CAAAR I)
|
||||
(QUOTE ITS))
|
||||
(CDR I))
|
||||
then (RPLACA (CDR I)
|
||||
(QUOTE (NIL)))
|
||||
(RPLACA I (QUOTE (NIL)))
|
||||
else (if (AND (EQ (CAAAR I)
|
||||
(QUOTE ITR))
|
||||
(CDR I))
|
||||
then (RPLACD (CADR I)
|
||||
NIL)
|
||||
(RPLACA I (QUOTE (NIL]
|
||||
(CONS (CAAR I)
|
||||
(CDDAR I]
|
||||
(SET TEST-SUITE-DATA (APPEND (EVALV TEST-SUITE-DATA)
|
||||
(LIST TEST-COMMANDS)))
|
||||
(MARKASCHANGED TEST-SUITE-DATA (QUOTE VARS)
|
||||
(QUOTE CHANGED))
|
||||
(SETQ TEST-BLOCK-START (CAAR LISPXHISTORY))
|
||||
(RETURN (QUOTE End-of-test-block)))
|
||||
else (ERROR (QUOTE ET)
|
||||
"no previous ADD-TO-TEST-SUITE"))
|
||||
else (ERROR (QUOTE ET)
|
||||
"has no test name supplied"])
|
||||
|
||||
(EXECUTE-TEST
|
||||
[LAMBDA (SUITE TEST-NAME) (* edited: "17-Sep-85 12:59")
|
||||
(PROG (TEST)
|
||||
(SETQ TEST (ASSOC TEST-NAME SUITE))
|
||||
(if TEST
|
||||
then (RETURN (EXECUTE-TEST-GUTS (CDR TEST)))
|
||||
else (ERROR TEST-NAME " is not a test name."])
|
||||
|
||||
(EXECUTE-TEST-GUTS
|
||||
[LAMBDA (TEST) (* edited: "17-Sep-85 12:54")
|
||||
(PROG (RESULT)
|
||||
(RETURN (for STEP in TEST always (PROGN (if (CDAR STEP)
|
||||
then (LISPXUNREAD (CDAR STEP)))
|
||||
(SETQ RESULT (LISPXEVAL (CAAR STEP)
|
||||
LISPXID))
|
||||
(if (CDR STEP)
|
||||
then (EQUAL RESULT (CADR STEP))
|
||||
else T])
|
||||
|
||||
(EXECUTE-TEST-SUITE
|
||||
[LAMBDA (SUITE) (* edited: "20-Sep-85 10:12")
|
||||
(for TEST in SUITE always (PROGN (PRINTOUT T "Executing " (CAR TEST)
|
||||
T)
|
||||
(PROG (RESULT)
|
||||
(SETQ RESULT (EXECUTE-TEST-GUTS (CDR TEST)))
|
||||
(if (NOT RESULT)
|
||||
then (PRINTOUT T (CAR TEST)
|
||||
" got an error." T))
|
||||
(RETURN RESULT])
|
||||
|
||||
(START-TEST-BLOCK
|
||||
[LAMBDA NIL (* scv "30-Aug-85 14:56")
|
||||
(if TEST-SUITE-DATA
|
||||
then (SETQ TEST-BLOCK-START (CAAR LISPXHISTORY))
|
||||
(QUOTE Start-of-test-block)
|
||||
else (ERROR (QUOTE ST)
|
||||
"no previous ADD-TO-TEST-SUITE"])
|
||||
|
||||
(TESTEXEC
|
||||
[LAMBDA NIL (* scv "30-Aug-85 10:16")
|
||||
(PROG (LISPXID)
|
||||
(SETQ LISPXID (QUOTE -))
|
||||
(RESETVARS (READBUF READBUFSOURCE REREADFLG)
|
||||
LP (PROMPTCHAR LISPXID T LISPXHISTORY)
|
||||
(ERSETQ (LISPX (LISPXREAD T T)
|
||||
LISPXID))
|
||||
(GO LP])
|
||||
)
|
||||
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
|
||||
(ADDTOVAR NLAML ADD-TO-TEST-SUITE)
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS TESTEXEC COPYRIGHT ("XEROX Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (830 5187 (ADD-TO-TEST-SUITE 840 . 1612) (END-TEST-BLOCK 1614 . 3192) (EXECUTE-TEST 3194
|
||||
. 3532) (EXECUTE-TEST-GUTS 3534 . 4011) (EXECUTE-TEST-SUITE 4013 . 4497) (START-TEST-BLOCK 4499 .
|
||||
4818) (TESTEXEC 4820 . 5185)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/TESTEXEC.LCOM
Normal file
BIN
internal/test/tools/TESTEXEC.LCOM
Normal file
Binary file not shown.
BIN
internal/test/tools/TESTEXEC.TEDIT
Normal file
BIN
internal/test/tools/TESTEXEC.TEDIT
Normal file
Binary file not shown.
3
internal/test/tools/TESTUSERS.TEDIT
Normal file
3
internal/test/tools/TESTUSERS.TEDIT
Normal file
File diff suppressed because one or more lines are too long
37
internal/test/tools/TESTUTILS
Normal file
37
internal/test/tools/TESTUTILS
Normal file
@@ -0,0 +1,37 @@
|
||||
(FILECREATED "20-Sep-85 09:23:53" {DANTE}<SVERNON>TESTUTILS.;2 1077
|
||||
|
||||
changes to: (FNS PRINT-TEST-ARS)
|
||||
(VARS TESTUTILSCOMS)
|
||||
|
||||
previous date: "19-Sep-85 17:02:23" {DANTE}<SVERNON>TESTUTILS.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by XEROX Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT TESTUTILSCOMS)
|
||||
|
||||
(RPAQQ TESTUTILSCOMS ((FNS PRINT-TEST-ARS)))
|
||||
(DEFINEQ
|
||||
|
||||
(PRINT-TEST-ARS
|
||||
[LAMBDA (WINDOW FILE) (* edited: "20-Sep-85 09:23")
|
||||
(PROG (STATUS)
|
||||
(SETQ STATUS NIL)
|
||||
(for I in (WINDOWPROP WINDOW (QUOTE AR.ENTRY.ALIST))
|
||||
do (if (NEQ (LISTGET (CDR I)
|
||||
(QUOTE Status:))
|
||||
STATUS)
|
||||
then (SETQ STATUS (LISTGET (CDR I)
|
||||
(QUOTE Status:)))
|
||||
(PRINTOUT FILE STATUS ":" T))
|
||||
(PRINTOUT FILE .I6 (LISTGET (CDR I)
|
||||
(QUOTE Number:))
|
||||
,
|
||||
(LISTGET (CDR I)
|
||||
(QUOTE Subject:))
|
||||
T])
|
||||
)
|
||||
(PUTPROPS TESTUTILS COPYRIGHT ("XEROX Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (367 997 (PRINT-TEST-ARS 377 . 995)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/TESTUTILS.LCOM
Normal file
BIN
internal/test/tools/TESTUTILS.LCOM
Normal file
Binary file not shown.
BIN
internal/test/tools/TESTUTILS.TEDIT
Normal file
BIN
internal/test/tools/TESTUTILS.TEDIT
Normal file
Binary file not shown.
362
internal/test/tools/VARBROWSER
Normal file
362
internal/test/tools/VARBROWSER
Normal file
@@ -0,0 +1,362 @@
|
||||
(FILECREATED "22-Jul-85 13:26:35" {DSK}<LISPFILES>UTILITIES>VARBROWSER.;2 12094
|
||||
|
||||
changes to: (FNS VARBROWSER VB.CREATE-LIST-OF-EQ-WIDTH-MENUS VB.CREATE-ICON-WINDOW)
|
||||
(VARS VARBROWSERCOMS VB.MASK VB.ICON)
|
||||
|
||||
previous date: "16-Jul-85 13:22:23" {DSK}<LISPFILES>UTILITIES>VARBROWSER.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT VARBROWSERCOMS)
|
||||
|
||||
(RPAQQ VARBROWSERCOMS ((FNS VARBROWSER VB.CREATE-ICON-WINDOW VB.CREATE-LIST-OF-EQ-WIDTH-MENUS
|
||||
VB.UPDATE-ALL-MENUS VB.UPDATE-MENU)
|
||||
(VARS VB.ICON VB.MASK)))
|
||||
(DEFINEQ
|
||||
|
||||
(VARBROWSER
|
||||
[LAMBDA (LIST-OF-VAR-RANGE-DEFAULT W-POSITION W-TITLE MENU-FONT VAR-NAMES-FONT MIN-MENU-WIDTH
|
||||
MAX-NAME-WIDTH) (* sm "22-Jul-85 13:22")
|
||||
(PROG (W W-REGION W-WIDTH W-HIGHT MENU-LIST POSITION-DECREMENT FIRST-POSITION MAX-MENU-WIDTH
|
||||
MENU-ITEM-HEIGHT INIT-VALUE)
|
||||
(if (NOT (AND MENU-FONT (FONTP MENU-FONT)))
|
||||
then (SETQ MENU-FONT (FONTCREATE (QUOTE GACHA)
|
||||
8)))
|
||||
[if (NOT (AND VAR-NAMES-FONT (FONTP MENU-FONT)))
|
||||
then (SETQ VAR-NAMES-FONT (FONTCREATE (QUOTE HELVETICA)
|
||||
8
|
||||
(QUOTE BOLD]
|
||||
(if (NULL MIN-MENU-WIDTH)
|
||||
then (SETQ MIN-MENU-WIDTH 5))
|
||||
[SETQ MAX-NAME-WIDTH (OR MAX-NAME-WIDTH (APPLY (QUOTE MAX)
|
||||
(for V in LIST-OF-VAR-RANGE-DEFAULT
|
||||
collect (NCHARS (CAR V]
|
||||
(SETQ MIN-MENU-WIDTH (ITIMES MIN-MENU-WIDTH (CHARWIDTH (CHARCODE M)
|
||||
MENU-FONT)))
|
||||
(SETQ X-OFFSET (ITIMES MAX-NAME-WIDTH (CHARWIDTH (CHARCODE M)
|
||||
VAR-NAMES-FONT)))
|
||||
(SETQ MENU-LIST (VB.CREATE-LIST-OF-EQ-WIDTH-MENUS LIST-OF-VAR-RANGE-DEFAULT MENU-FONT
|
||||
MIN-MENU-WIDTH))
|
||||
(SETQ MAX-MENU-WIDTH (fetch IMAGEWIDTH of (CAR MENU-LIST)))
|
||||
(SETQ W-WIDTH (IPLUS MAX-MENU-WIDTH 10 X-OFFSET))
|
||||
[SETQ MENU-ITEM-HEIGHT (ADD1 (fetch ITEMHEIGHT of (CAR MENU-LIST]
|
||||
(SETQ W-HEIGHT (IPLUS (ITIMES (LENGTH MENU-LIST)
|
||||
MENU-ITEM-HEIGHT)
|
||||
20))
|
||||
(SETQ FIRST-POSITION (IDIFFERENCE W-HEIGHT (IPLUS 20 MENU-ITEM-HEIGHT)))
|
||||
(SETQ POSITION-DECREMENT (MINUS MENU-ITEM-HEIGHT))
|
||||
(SETQ W-REGION (if W-POSITION
|
||||
then (SETQ W-REGION (CREATEREGION (fetch XCOORD of W-POSITION)
|
||||
(fetch YCOORD of W-POSITION)
|
||||
W-WIDTH W-HEIGHT))
|
||||
else (GETBOXREGION W-WIDTH W-HEIGHT NIL NIL NIL
|
||||
"Specify position for varbrowser window")))
|
||||
(SETQ W (CREATEW W-REGION (OR W-TITLE "Varbrowser window")))
|
||||
(WINDOWPROP W (QUOTE ICONFN)
|
||||
(QUOTE VB.CREATE-ICON-WINDOW))
|
||||
(for M in MENU-LIST as VAR-VALUES-DEFAULTE in LIST-OF-VAR-RANGE-DEFAULT as Y from
|
||||
FIRST-POSITION
|
||||
by POSITION-DECREMENT
|
||||
do (MOVETO 3 Y W)
|
||||
(DSPFONT VAR-NAMES-FONT W)
|
||||
(printout W (CAR VAR-VALUES-DEFAULTE))
|
||||
(DRAWCURVE (LIST (create POSITION
|
||||
XCOORD _(DSPXPOSITION NIL W)
|
||||
YCOORD _(DSPYPOSITION NIL W))
|
||||
(create POSITION
|
||||
XCOORD _ X-OFFSET
|
||||
YCOORD _ Y))
|
||||
NIL
|
||||
(QUOTE (ROUND 1))
|
||||
(QUOTE (1 3))
|
||||
W)
|
||||
(ADDMENU M W (create POSITION
|
||||
XCOORD _ X-OFFSET
|
||||
YCOORD _ Y))
|
||||
(COND
|
||||
((CDDR VAR-VALUES-DEFAULTE)
|
||||
(SETQ INIT-VALUE (CADDR VAR-VALUES-DEFAULTE))
|
||||
(SET (CAR VAR-VALUES-DEFAULTE)
|
||||
INIT-VALUE))
|
||||
[(BOUNDP (CAR VAR-VALUES-DEFAULTE))
|
||||
(SETQ INIT-VALUE (EVAL (CAR VAR-VALUES-DEFAULTE]
|
||||
(T (SETQ INIT-VALUE NIL)))
|
||||
(VB.UPDATE-MENU M INIT-VALUE))
|
||||
(WINDOWPROP W (QUOTE OPENFN)
|
||||
(QUOTE VB.UPDATE-ALL-MENUS))
|
||||
(WINDOWPROP W (QUOTE EXPANDFN)
|
||||
(QUOTE VB.UPDATE-ALL-MENUS))
|
||||
(RETURN W])
|
||||
|
||||
(VB.CREATE-ICON-WINDOW
|
||||
[LAMBDA (WINDOW ICON) (* sm "22-Jul-85 13:23")
|
||||
[COND
|
||||
((NULL ICON)
|
||||
(SETQ ICON (TITLEDICONW (create TITLEDICON
|
||||
ICON _ VB.ICON
|
||||
MASK _ VB.MASK
|
||||
TITLEREG _(CREATEREGION 3 3 65 40))
|
||||
(WINDOWPROP WINDOW (QUOTE TITLE))
|
||||
(FONTCREATE (QUOTE GACHA)
|
||||
8]
|
||||
ICON])
|
||||
|
||||
(VB.CREATE-LIST-OF-EQ-WIDTH-MENUS
|
||||
[LAMBDA (LIST-OF-VAR-RANGE-DEFAULT MENU-FONT MIN-MENU-WIDTH)
|
||||
(* sm "22-Jul-85 12:41")
|
||||
(PROG (TEMP-MENU-LIST MAX-WIDTH)
|
||||
[SETQ MAX-WIDTH (APPLY (QUOTE MAX)
|
||||
(for VAR-RANGE-DEFAULT in LIST-OF-VAR-RANGE-DEFAULT
|
||||
collect (if (CADR VAR-RANGE-DEFAULT)
|
||||
then [ITIMES
|
||||
(LENGTH (CADR VAR-RANGE-DEFAULT))
|
||||
(APPLY (QUOTE MAX)
|
||||
(for VALUE in (CADR VAR-RANGE-DEFAULT)
|
||||
collect (IPLUS (STRINGWIDTH
|
||||
(MKSTRING VALUE)
|
||||
MENU-FONT)
|
||||
8]
|
||||
else MIN-MENU-WIDTH]
|
||||
(RETURN (for VAR-RANGE-DEFAULT in LIST-OF-VAR-RANGE-DEFAULT
|
||||
collect (create MENU
|
||||
ITEMS _[if (CADR VAR-RANGE-DEFAULT)
|
||||
then (for V in (CADR VAR-RANGE-DEFAULT)
|
||||
collect (LIST V (CAR VAR-RANGE-DEFAULT)))
|
||||
else (LIST (LIST " " (LIST (CAR VAR-RANGE-DEFAULT]
|
||||
MENUROWS _ 1
|
||||
MENUFONT _ MENU-FONT
|
||||
CENTERFLG _ T
|
||||
ITEMWIDTH _[IQUOTIENT MAX-WIDTH (MAX 1 (LENGTH (CADR
|
||||
VAR-RANGE-DEFAULT]
|
||||
WHENSELECTEDFN _(QUOTE
|
||||
(LAMBDA (ITEM MEN KEY)
|
||||
(PROG (NEW-VAL REG WIND)
|
||||
(SETQ WIND (WFROMMENU MEN))
|
||||
(if (LISTP (CADR ITEM))
|
||||
then (DSPFILL (SETQ REG (MENUITEMREGION
|
||||
ITEM MEN))
|
||||
WHITESHADE
|
||||
(QUOTE REPLACE)
|
||||
WIND)
|
||||
(DSPFONT (fetch MENUFONT of MEN)
|
||||
WIND)
|
||||
(MOVETO (IPLUS 2 (fetch LEFT
|
||||
of REG))
|
||||
(IPLUS 2 (fetch BOTTOM
|
||||
of REG))
|
||||
WIND)
|
||||
[SETQ NEW-VAL
|
||||
(MKATOM (PROMPTFORWORD NIL NIL NIL
|
||||
WIND NIL
|
||||
(QUOTE TTY]
|
||||
(SET (CAADR ITEM)
|
||||
NEW-VAL)
|
||||
(RPLACA ITEM NEW-VAL)
|
||||
else (for I in (fetch ITEMS of MEN)
|
||||
do (SHADEITEM I MEN WHITESHADE))
|
||||
(SET (CADR ITEM)
|
||||
(CAR ITEM))
|
||||
(SHADEITEM ITEM MEN BLACKSHADE])
|
||||
|
||||
(VB.UPDATE-ALL-MENUS
|
||||
[LAMBDA (W) (* sm "16-Jul-85 13:16")
|
||||
(PROG (VAR-NAME)
|
||||
(for ONE-MENU in (WINDOWPROP W (QUOTE MENU))
|
||||
do (VB.UPDATE-MENU ONE-MENU (if (BOUNDP (if [LISTP (SETQ VAR-NAME
|
||||
(CADAR (fetch ITEMS of ONE-MENU]
|
||||
then (SETQ VAR-NAME (CAR VAR-NAME))
|
||||
else VAR-NAME))
|
||||
then (EVAL VAR-NAME)
|
||||
else NIL)))
|
||||
(RETURN W])
|
||||
|
||||
(VB.UPDATE-MENU
|
||||
[LAMBDA (MENU VALUE) (* sm "16-Jul-85 13:08")
|
||||
(PROG (WINDOW ITEMS REG)
|
||||
(SETQ ITEMS (fetch ITEMS of MENU))
|
||||
(SETQ WINDOW (WFROMMENU MENU))
|
||||
(if (AND (EQP (LENGTH ITEMS)
|
||||
1)
|
||||
(LISTP (CADAR ITEMS)))
|
||||
then (DSPFILL (SETQ REG (MENUITEMREGION (CAR ITEMS)
|
||||
MENU))
|
||||
WHITESHADE
|
||||
(QUOTE REPLACE)
|
||||
WINDOW)
|
||||
(DSPFONT (fetch MENUFONT of MENU)
|
||||
WINDOW)
|
||||
(MOVETO (IPLUS 2 (fetch LEFT of REG))
|
||||
(IPLUS 2 (fetch BOTTOM of REG))
|
||||
WINDOW)
|
||||
(PRIN1 VALUE WINDOW)
|
||||
else (for ITEM in ITEMS
|
||||
do (SHADEITEM ITEM MENU WHITESHADE)
|
||||
(COND
|
||||
((AND (BOUNDP (CADR ITEM))
|
||||
(EQUAL (EVAL (CADR ITEM))
|
||||
(CAR ITEM)))
|
||||
(SHADEITEM ITEM MENU BLACKSHADE])
|
||||
)
|
||||
|
||||
(RPAQ VB.ICON (READBITMAP))
|
||||
(75 75
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"LOOOOOOOOOOOOOOOONF@"
|
||||
"LOFJLKOOOOOOOOOOONF@"
|
||||
"LOBMCKOOOOOOOOOOONF@"
|
||||
"LOOOOOOOOOOOOOOOONF@"
|
||||
"LH@@@@@@@@@@@@@@@BF@"
|
||||
"LH@@@@@@COOOOOOOOJF@"
|
||||
"LH@@@@@@B@B@DA@D@JF@"
|
||||
"LH@@@@@@B@B@DA@D@JF@"
|
||||
"LH@@@@@@COOOOOOOOJF@"
|
||||
"LH@@@@@@COOL@@D@@JF@"
|
||||
"LJKKCD@@COOL@@D@@JF@"
|
||||
"LKBJHDAEGOOOOOOOOJF@"
|
||||
"LH@@@@@@B@@@AOOOOJF@"
|
||||
"LJKK@@@@B@@@AOOOOJF@"
|
||||
"LKJJAEEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@BAOAAAAA@JF@"
|
||||
"LJKKDN@@BAOAAAAA@JF@"
|
||||
"LKJJFHEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@B@@@@@@@@JF@"
|
||||
"LJ@JAH@@B@@@@@@@@JF@"
|
||||
"LKKKMAEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@B@@@@@@@@JF@"
|
||||
"LJCKL@@@B@@@@@@@@JF@"
|
||||
"LKJJEEEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@B@DAOHDB@JF@"
|
||||
"LHJFI@@@B@DAOHDB@JF@"
|
||||
"LKKDMEEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@B@@COOL@@JF@"
|
||||
"LJKJ@@@@B@@COOL@@JF@"
|
||||
"LIJJEEEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@COHA@B@D@JF@"
|
||||
"LKIIL@@@COHA@B@D@JF@"
|
||||
"LJBEBEEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@B@@@@@@@@JF@"
|
||||
"LKJF@@@@B@@@@@@@@JF@"
|
||||
"LJCBEEEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@B@@@@OOOOJF@"
|
||||
"LJCJH@@@B@@@@OOOOJF@"
|
||||
"LKJBNEEEGOOOOOOOOJF@"
|
||||
"LH@@@@@@@@@@@@@@@BF@"
|
||||
"LOOOOOOOOOOOOOOOONF@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"L@@@@@@@@@@@@@@@@@F@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@")
|
||||
|
||||
(RPAQ VB.MASK (READBITMAP))
|
||||
(75 75
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@"
|
||||
"OOOOOOOOOOOOOOOOOON@")
|
||||
(PUTPROPS VARBROWSER COPYRIGHT ("Xerox Corporation" 1985))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (585 8489 (VARBROWSER 595 . 4133) (VB.CREATE-ICON-WINDOW 4135 . 4536) (
|
||||
VB.CREATE-LIST-OF-EQ-WIDTH-MENUS 4538 . 6942) (VB.UPDATE-ALL-MENUS 6944 . 7487) (VB.UPDATE-MENU 7489
|
||||
. 8487)))))
|
||||
STOP
|
||||
BIN
internal/test/tools/VARBROWSER.LCOM
Normal file
BIN
internal/test/tools/VARBROWSER.LCOM
Normal file
Binary file not shown.
Reference in New Issue
Block a user